diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,95 @@ +# Revision history for solana-haskell-sdk + +## 1.2.0.0 -- 2026-08-03 + +* Added on-chain account-state decoders (SPL token accounts and mints, address lookup tables, stake and nonce accounts, Metaplex metadata) with typed SolanaWeb3 fetch helpers; decoded lookup tables feed compileV0Message directly. +* Added developer-experience helpers: explicit fee-payer transactions with automatic signature ordering (sponsored fees supported), a durable-nonce transaction flow, and priority-fee estimation. +* Added an opt-in local-validator integration test suite (`integration-tests`, behind the `integration` cabal flag) covering SOL and sponsored transfers, the SPL token lifecycle, durable nonces, address lookup tables with v0 transactions, priority fees, and WebSocket confirmation; the suite skips itself when no validator is running. +* Added golden tests for the JSON-RPC response parsers, replaying 37 responses recorded from a live validator by `tools/rpc-record`, so every `FromJSON` instance is asserted against JSON a node actually sends. +* Added Solana PubSub (WebSocket) support in `Network.Solana.RPC.WebSocket`: signature and account subscribe/unsubscribe requests, notification parsing, and `awaitSignature` — a push-based confirmation that replaces polling. The module is transport-agnostic (`WsTransport`), so the library gains no new dependency and works with both `ws://` and `wss://` endpoints. + +## 1.1.0.0 -- 2026-08-01 + +* Added Metaplex Token Metadata client (CreateMetadataAccountV3, UpdateMetadataAccountV2, CreateMasterEditionV3) with metadata/master-edition PDA derivation, built on a new minimal Borsh serialization layer. +* Added Address Lookup Table program client and versioned (v0) transaction support: compile messages against lookup tables and sign VersionedTransactions (encode-only; account-state parsing out of scope). The `CompileException` constructor (`MissingIndex`) is now exported for error inspection. +* Hackage-ready packaging: PVP upper bounds on all dependencies; homepage and bug-reports metadata. + +## 1.0.0.0 -- 2026-08-01 + +First stable release: byte-verified clients for System, Compute Budget, Stake, Vote, BPF Loader (upgradeable), Secp256k1, SPL Memo, SPL Token, and Associated Token Account programs; PDA derivation; canonical Rust-identical message compilation. + +* Changed: `sendTransaction`'s default configuration no longer skips preflight + simulation and no longer caps retries — submissions now follow the node's + defaults (preflight runs; the node rebroadcasts until blockhash expiry). + Transactions failing simulation return an RPC error instead of a signature. +* Changed: account-fetching RPC methods now request `base64` encoding + explicitly for reliable binary account data. +* Hardened all RPC-facing JSON parsers to be total: malformed or unexpected + node responses (failed transactions, v0 transactions, pruned/unknown slots) + no longer crash the client. +* Fixed: `mkPrivateKeyFromString` rejected valid 64-byte private keys; now + parses them correctly. +* Fixed: `BlockHash` and `CompactArray` `Binary` decoding were asymmetric + with their `put` (falling back to an incompatible/length-prefixed + decoder); both now round-trip correctly. +* Fixed documentation typos referring to the `RPCResponse` type (the + exported name never changed) and renamed RPC fields for consistency + (`Ammount*` -> `Amount*`); changed transaction/account error fields to + structured `Maybe Value` instead of partial `Maybe String`. +* Renamed `ClusterNodes.sharedVersion` to `shredVersion` (typo fix; matches + the RPC field). +* Added `confirmTransaction` to `SolanaWeb3`: polls for `confirmed`/ + `finalized` status instead of a fixed `wait`. +* Haddock coverage completed for the Core, RPC/HTTP, and SolanaWeb3 modules + touched by the quality pass (module headers and per-export documentation); + `cabal haddock` exits 0 with a handful of internal native/SPL-program + helpers still undocumented. +* Added upgradeable BPF loader client (buffer/write/deploy/upgrade/authority/ + close/extend) with program-data address derivation. +* Added secp256k1 precompile client: signature-verification instruction + construction from a precomputed signature (signing is out of scope). +* Added Stake program client (initialize, authorize, delegate, split, withdraw, + deactivate, lockup, merge, checked variants) — golden-tested against the Rust SDK. +* Added Vote program client (account management: initialize, authorize, withdraw, + identity/commission updates); consensus voting instructions are out of scope. +* Added SPL Token program client (instructions 0-20: mint/account initialization, + transfers, approvals, minting, burning, freezing, multisig support) — + golden-tested against the `spl-token` Rust crate. +* Added Associated Token Account program client with address derivation. +* Added Program Derived Address (PDA) support: `createProgramAddress` / + `findProgramAddress` with ed25519 on-curve rejection (new `crypton` and `memory` dependencies). +* Added Compute Budget program client: request heap frame, set compute unit + limit, set compute unit price (priority fees), set loaded accounts data size + limit — golden-tested against the Rust SDK. +* Added SPL Memo (v2) program client. +* Added binary decoding for `SystemInstruction` and `ComputeBudgetInstruction` + (symmetric `Binary` instances, round-trip tested). +* Fixed: account keys within each privilege section are now ordered + canonically (sorted by pubkey, fee payer first) to match the Rust SDK, so + multi-program messages serialize byte-identically. For multi-signer + transactions, signing keys must be passed in the canonical account order + (fee payer first). +* Test suite: golden vectors generated from the Rust `solana-sdk` (byte-for-byte + serialization checks at instruction, message, and signed-transaction level), + plus QuickCheck properties for compact-u16, crypto round-trips, and message + header/key-ordering invariants. +* Fixed: pubkeys inside System Program instruction data were serialized with a + length prefix (invalid wire format). +* Fixed: `CreateAccountWithSeed` seed was missing its u64 length prefix. +* Fixed: `SolanaSignature` binary decoding read 32 bytes instead of 64. +* Fixed: the program id was appended as an extra account to every instruction; + it is now added only to the message account keys. +* Fixed: account privilege deduplication in message building used the wrong + buckets to decide writability, producing duplicate keys or wrongly-writable + accounts when the same account appeared in several instructions with mixed + privileges. +* Fixed: compact-u16 decoding now rejects aliased (non-canonical) encodings. +* Fixed: `CompiledInstruction` JSON parsing fails cleanly on invalid base58. +* Added the 9 remaining System Program instructions: nonce account management + (advance, withdraw, initialize, authorize, upgrade) and + allocate/assign/transfer with seed. +* Added CI (GitHub Actions). + +## 0.1.0.0 -- 2024 (unreleased alpha) + +* Initial alpha: JSON-RPC API client, key management, System Program transfers. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,257 @@ + +

+ + Solana Haskell SDK Logo + +

Solana SDK library for Haskellers

+

+ + + + + + + + + +

+

+ +## Table of contents + +- 📋 [Documentation](#documentation) +- 🧪 [Integration tests](#integration-tests) +- 🔌 [WebSocket subscriptions](#websocket-subscriptions) +- 🚀 [Features](#features) +- 🧑‍💻 [Usage Examples](#usage-examples) +- 📝 [Contributing](#contributing) +- ✨ [Credits](#credits) +- ⚖️ [License](#license) + +## Documentation + +API documentation is generated with Haddock (`cabal haddock`). Serialization correctness methodology: every instruction, message, and transaction encoder is asserted byte-identical to vectors generated from the official Rust crates (solana-sdk, spl-token, mpl-token-metadata) — see [tools/README.md](https://github.com/mariusgeorgescu/solana-haskell-sdk/blob/main/tools/README.md). + +## Integration tests + +An opt-in test suite runs the SDK against a local validator. It sits behind the `integration` cabal flag, so a plain `cabal test all` neither builds it nor pulls its extra dependencies: + + solana-test-validator --reset + cabal test integration-tests --flags=integration + +Without a validator listening on `127.0.0.1:8899` the suite skips itself and exits 0, so it stays green in CI even when enabled. Set `SOLANA_INTEGRATION=1` to make an unreachable validator a failure instead, or `SOLANA_RPC_URL` to target a different endpoint. + +## WebSocket subscriptions + +`Network.Solana.RPC.WebSocket` speaks Solana's PubSub protocol: signature and account subscriptions, and `awaitSignature`, which waits for a transaction to be *pushed* to you instead of polling for it. + +The module is transport-agnostic, so the SDK carries no WebSocket dependency and the same code serves plain `ws://` and TLS `wss://` endpoints — you supply the connection. With the [`websockets`](https://hackage.haskell.org/package/websockets) package: + +```haskell +import Network.Solana.RPC.WebSocket +import Network.WebSockets qualified as WS + +WS.runClient "127.0.0.1" 8900 "/" $ \conn -> do + let transport = WsTransport (WS.sendTextData conn) (WS.receiveData conn) + result <- awaitSignature transport (RequestId 1) (Just "confirmed") 30 signature + print result -- Right , or Left with the on-chain or protocol error +``` + +For `wss://` endpoints use [`wuss`](https://hackage.haskell.org/package/wuss)'s `runSecureClient` in place of `runClient`; nothing else changes. + +## Features + +- [x] Full JSON-RPC API client (accounts, blocks, chain, ledger, tokens, tokenomics, transactions) +- [x] Wallet, account and keys management (ed25519 keypairs, base58 addresses) +- [x] Program Derived Addresses (`findProgramAddress` / `createProgramAddress`) +- [x] Transaction building, signing and submission + - [x] Priority fees via Compute Budget (`setComputeUnitLimit`, `setComputeUnitPrice`) + - [x] Versioned (v0) transactions and Address Lookup Tables + - [x] Clients for native programs + - [x] Address Lookup Table + - [x] BPF Loader (upgradeable) + - [x] Compute Budget + - [x] Secp256k1 (instruction construction; signing out of scope) + - [x] Stake (delegation lifecycle; seed-authority variants out of scope) + - [x] System Program (all 13 instructions) + - [x] Vote (account management) + - [x] Clients for Solana Program Library (SPL) + - [x] Memo + - [x] SPL Token (instructions 0-20, incl. `transferChecked`) + - [x] Associated Token Account (derive + create, idempotent variant) + - [x] Metaplex Token Metadata (create/update metadata, master edition) +- [x] On-chain account state decoders (SPL token accounts and mints, lookup tables, stake and nonce accounts, Metaplex metadata) +- [x] PubSub (WebSocket) signature and account subscriptions, with push-based confirmation +- [x] Serialization verified byte-for-byte against the official Rust crates (solana-sdk, spl-token, mpl-token-metadata) (golden-vector tests) + +### Release status + +The current stable release is **v1.2.0.0**. Serialization is verified byte-for-byte against the official Rust SDK by golden-vector tests (see test/fixtures/ and [tools/README.md](https://github.com/mariusgeorgescu/solana-haskell-sdk/blob/main/tools/README.md)). + +## Usage Examples + +### Simple transfer + +This example demonstrates how to use the Haskell Solana SDK to interact with a Solana validator and perform basic blockchain operations such as keypair generation, account funding via airdrop, balance checking, and transferring SOL tokens. + +In the provided sample: + +1. We start by generating a new keypair to act as the transaction sender and fee payer. + +2. We connect to a local Solana validator using an HTTP provider. + +3. The newly generated keypair receives an airdrop of 10 SOL to ensure it has sufficient funds. + +4. We define a recipient's public address from a base58 encoded string. + +5. We **construct**, **sign** and **submit** the transaction by defining the signers and the transaction's list of instructions with their parameters. + +Before and after performing the transfer of 1 SOL to the recipient, we check and print the account balances to verify the transaction's success. + +This straightforward example highlights the convenience and expressiveness of Haskell when building decentralized applications on Solana. + +> The examples use `GHC2021` (this package's `default-language`). If you compile them under `Haskell2010`, additionally enable `NumericUnderscores` and `ImportQualifiedPost`. + +```haskell +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Monad (void) +import Control.Monad.IO.Class (liftIO) +import Network.Solana.Core.Crypto +import Network.Solana.NativePrograms.SystemProgram qualified as SystemProgram +import Network.Solana.RPC.HTTP.Transaction +import Network.Solana.SolanaWeb3 +import Network.Web3.Provider + +main :: IO () +main = do + -- Generate keypairs for fee payer (sender) + (myPublicKey, myPrivateKey) <- createSolanaKeyPair + + -- Create Connection, local validator in this example + result <- runWeb3' (HttpProvider "http://127.0.0.1:8899") $ do + -- Fund fee payer + void $ requestAirdrop myPublicKey 10_000_000_000 + wait 15 -- Wait 15 seconds be sure the tx was confirmed + + -- Define recipient's address from a base58-encoded string + let recipient = "A988FuUtUVk8jMUuVc1ccaoTA3VS9CB4dkEf9XUAUqV4" + + -- Check balance + printBalances [myPublicKey, recipient] + + -- Create a new transaction. + txId <- + newTransaction + [myPrivateKey] -- Signing keys (with all required signers) + -- List of instructions + [ SystemProgram.transfer + myPublicKey -- sender address + recipient -- recipient address + 1_000_000_000 -- amount to transfer 1 SOL + ] + liftIO $ putStrLn ("Transaction sent: " <> show txId) + + void $ confirmTransaction txId + -- Check balance + printBalances [myPublicKey, recipient] + + either (\e -> putStrLn ("RPC error: " <> show e)) pure result +``` + +### SPL token transfer (Associated Token Accounts) + +Tokens live in *associated token accounts* (ATAs) — program-derived addresses computed from the wallet and the mint. This example derives both ATAs with `getAssociatedTokenAddress`, creates the recipient's ATA if missing (idempotent, safe to include unconditionally), and moves tokens with the decimals-checked `transferChecked`. + +```haskell +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Monad (void) +import Data.Maybe (fromJust) +import Network.Solana.Core.Crypto +import Network.Solana.SolanaWeb3 +import Network.Solana.SplPrograms.AssociatedTokenAccount qualified as Ata +import Network.Solana.SplPrograms.Token qualified as Token +import Network.Web3.Provider + +main :: IO () +main = do + (myPublicKey, myPrivateKey) <- createSolanaKeyPair + + void $ runWeb3' (HttpProvider "http://127.0.0.1:8899") $ do + let mint = "4zMMC9srt5Ri5X14GAgXhaHii3GnPAEERYPJgZJDncDU" -- the token's mint address + recipient = "A988FuUtUVk8jMUuVc1ccaoTA3VS9CB4dkEf9XUAUqV4" -- recipient wallet + + -- ATAs are PDAs of (wallet, token program, mint): derived, not generated. + sourceAta = fromJust (Ata.getAssociatedTokenAddress myPublicKey mint) + destinationAta = fromJust (Ata.getAssociatedTokenAddress recipient mint) + + void $ + newTransaction + [myPrivateKey] + [ -- Create the recipient's token account if it does not exist yet (no-op otherwise). + Ata.createAssociatedTokenAccountIdempotent + myPublicKey -- funder (pays rent) + recipient -- wallet that will own the ATA + mint, + -- Transfer 1 token (here: 6 decimals); mint and decimals are verified on-chain. + Token.transferChecked + sourceAta -- source token account + mint -- token mint + destinationAta -- destination token account + myPublicKey -- owner of the source account + [] -- extra multisig signers (none) + 1_000_000 -- amount in base units + 6 -- decimals of the mint + ] +``` + +### Priority fees and memo + +Compute Budget instructions raise a transaction's scheduling priority by paying a fee per compute unit; a memo attaches a signed, human-readable note recorded on-chain. Both are ordinary `Instruction`s added to the same instruction list. + +```haskell +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Monad (void) +import Network.Solana.Core.Crypto +import Network.Solana.NativePrograms.ComputeBudget qualified as ComputeBudget +import Network.Solana.NativePrograms.SystemProgram qualified as SystemProgram +import Network.Solana.SolanaWeb3 +import Network.Solana.SplPrograms.Memo qualified as Memo +import Network.Web3.Provider + +main :: IO () +main = do + (myPublicKey, myPrivateKey) <- createSolanaKeyPair + + void $ runWeb3' (HttpProvider "http://127.0.0.1:8899") $ do + let recipient = "A988FuUtUVk8jMUuVc1ccaoTA3VS9CB4dkEf9XUAUqV4" + + void $ + newTransaction + [myPrivateKey] + [ ComputeBudget.setComputeUnitLimit 200_000, -- cap the compute units this tx may use + ComputeBudget.setComputeUnitPrice 10_000, -- priority fee: micro-lamports per compute unit + SystemProgram.transfer myPublicKey recipient 1_000_000_000, -- 1 SOL + Memo.buildMemo "thanks for the coffee" [myPublicKey] -- signed on-chain note + ] +``` + +## Contributing + +We welcome all contributors! See [contributing guide](https://github.com/mariusgeorgescu/solana-haskell-sdk/blob/main/CONTRIBUTING.md) for how to get started. + +## Credits + +Created and maintained by Marius Georgescu. + +## License + +[Apache-2.0](https://github.com/mariusgeorgescu/solana-haskell-sdk/blob/main/LICENSE) diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Monad (void) +import Control.Monad.IO.Class (liftIO) +import Network.Solana.Core.Crypto +import Network.Solana.NativePrograms.SystemProgram qualified as SystemProgram +import Network.Solana.RPC.HTTP.Transaction +import Network.Solana.SolanaWeb3 +import Network.Web3.Provider + +main :: IO () +main = do + -- Generate keypairs for fee payer (sender) + (myPublicKey, myPrivateKey) <- createSolanaKeyPair + + -- Create Connection, local validator in this example + result <- runWeb3' (HttpProvider "http://127.0.0.1:8899") $ do + -- Fund fee payer + void $ requestAirdrop myPublicKey 10_000_000_000 + wait 15 -- Wait 15 seconds be sure the tx was confirmed + + -- Define recipient's address from a base58-encoded string + let recipient = "A988FuUtUVk8jMUuVc1ccaoTA3VS9CB4dkEf9XUAUqV4" + + -- Check balance + printBalances [myPublicKey, recipient] + + -- Create a new transaction. + txId <- + newTransaction + [myPrivateKey] -- Signing keys (with all required signers) + -- List of instructions + [ SystemProgram.transfer + myPublicKey -- sender address + recipient -- recipient address + 1_000_000_000 -- amount to transfer 1 SOL + ] + liftIO $ putStrLn ("Transaction sent: " <> show txId) + + void $ confirmTransaction txId + -- Check balance + printBalances [myPublicKey, recipient] + + either (\e -> putStrLn ("RPC error: " <> show e)) pure result diff --git a/solana-haskell-sdk.cabal b/solana-haskell-sdk.cabal new file mode 100644 --- /dev/null +++ b/solana-haskell-sdk.cabal @@ -0,0 +1,215 @@ +cabal-version: 3.0 +name: solana-haskell-sdk +version: 1.2.0.0 +synopsis: Solana SDK: transaction building, signing, program clients, and JSON-RPC. +homepage: https://github.com/mariusgeorgescu/solana-haskell-sdk +bug-reports: https://github.com/mariusgeorgescu/solana-haskell-sdk/issues + +-- A longer description of the package. +description: + This library includes features like key generation and management, + transaction and instruction construction, and a JSON-RPC API client. + + This library is aimed at developers building Solana dApps, tools, or infrastructure in Haskell. + + All serialization is verified byte-for-byte against the official Rust SDK by golden-vector tests. + +license: Apache-2.0 +license-file: LICENSE +author: Marius Georgescu +maintainer: georgescumarius@live.com +copyright: 2024 Marius Georgescu +category: Blockchain, Web3, Solana +build-type: Simple +tested-with: GHC ==9.6.7 + +-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README. +extra-doc-files: + CHANGELOG.md + README.md + +-- Extra source files to be distributed with the package, such as examples, or a tutorial module. +extra-source-files: + test/fixtures/*.json + +flag integration + description: + Build the local-validator integration test suite. Off by default so that + building this package's tests needs no WebSocket dependency and no running + validator; see the Integration tests section of the README. + + default: False + manual: True + +common warnings + ghc-options: -Wall + +library + -- Import common warning flags. + import: warnings + + -- Modules exported by the library. + exposed-modules: + Network.Solana.Constants + Network.Solana.Core.Account + Network.Solana.Core.Block + Network.Solana.Core.Borsh + Network.Solana.Core.Compact + Network.Solana.Core.Crypto + Network.Solana.Core.Instruction + Network.Solana.Core.Message + Network.Solana.Core.Pda + Network.Solana.Core.Transaction + Network.Solana.Core.VersionedMessage + Network.Solana.Metaplex.TokenMetadata + Network.Solana.NativePrograms.AddressLookupTable + Network.Solana.NativePrograms.BpfLoaderUpgradeable + Network.Solana.NativePrograms.ComputeBudget + Network.Solana.NativePrograms.Secp256k1 + Network.Solana.NativePrograms.Stake + Network.Solana.NativePrograms.SystemProgram + Network.Solana.NativePrograms.Vote + Network.Solana.SplPrograms.AssociatedTokenAccount + Network.Solana.SplPrograms.Memo + Network.Solana.SplPrograms.Token + Network.Solana.RPC.HTTP.Account + Network.Solana.RPC.HTTP.Block + Network.Solana.RPC.HTTP.Chain + Network.Solana.RPC.HTTP.Ledger + Network.Solana.RPC.HTTP.Token + Network.Solana.RPC.HTTP.Tokenomics + Network.Solana.RPC.HTTP.Transaction + Network.Solana.RPC.HTTP.Types + Network.Solana.RPC.WebSocket + Network.Solana.SolanaWeb3 + Network.Solana.Sysvar + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: + , aeson ^>=2.2 + , base ^>=4.18.0.0 + , base58-bytestring ^>=0.1 + , base64 ^>=1.0 + , binary ^>=0.8 + , bytestring ^>=0.11 + , containers ^>=0.6 + , crypton ^>=1.0 + , ed25519 ^>=0.0.5 + , either ^>=5.0 + , extra ^>=1.8 + , jsonrpc-tinyclient ^>=1.1 + , memory ^>=0.18 + , mtl ^>=2.3 + , text ^>=2.0 + , vector ^>=0.13 + , web3 ^>=1.1 + + -- Directories containing source files. + hs-source-dirs: src + + -- Base language which the package is written in. + default-language: GHC2021 + +executable solana-haskell-sdk + -- Import common warning flags. + import: warnings + + -- .hs or .lhs file containing the Main module. + main-is: Main.hs + + -- Modules included in this executable, other than Main. + -- other-modules: Demos + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: + , base ^>=4.18.0.0 + , solana-haskell-sdk + , web3-provider ^>=1.1 + + -- Directories containing source files. + hs-source-dirs: app + + -- Base language which the package is written in. + default-language: GHC2021 + +test-suite solana-haskell-sdk-test + import: warnings + default-language: GHC2021 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: + Test.Core.Account + Test.Core.Block + Test.Core.Borsh + Test.Core.Compact + Test.Core.Crypto + Test.Core.Instruction + Test.Core.Message + Test.Core.Pda + Test.Core.VersionedMessage + Test.Fixtures + Test.Metaplex.TokenMetadata + Test.NativePrograms.AddressLookupTable + Test.NativePrograms.BpfLoaderUpgradeable + Test.NativePrograms.ComputeBudget + Test.NativePrograms.Secp256k1 + Test.NativePrograms.Stake + Test.NativePrograms.SystemProgram + Test.NativePrograms.Vote + Test.RPC.Chain + Test.RPC.Parsers + Test.RPC.WebSocket + Test.SplPrograms.AssociatedTokenAccount + Test.SplPrograms.Memo + Test.SplPrograms.Token + build-depends: + , aeson ^>=2.2 + , base ^>=4.18.0.0 + , base16-bytestring ^>=1.0 + , binary ^>=0.8 + , bytestring ^>=0.11 + , containers ^>=0.6 + , solana-haskell-sdk + , tasty ^>=1.5 + , tasty-hunit ^>=0.10 + , tasty-quickcheck ^>=0.11 + , text ^>=2.0 + +test-suite integration-tests + import: warnings + default-language: GHC2021 + type: exitcode-stdio-1.0 + hs-source-dirs: test-integration + main-is: Main.hs + other-modules: + Test.Integration.Alt + Test.Integration.Nonce + Test.Integration.PriorityFee + Test.Integration.Setup + Test.Integration.Token + Test.Integration.Transfer + Test.Integration.WebSocket + build-depends: + , base ^>=4.18.0.0 + , solana-haskell-sdk + , tasty ^>=1.5 + , tasty-hunit ^>=0.10 + , web3-provider ^>=1.1 + , websockets ^>=0.13 + + if !flag(integration) + buildable: False + +source-repository head + type: git + location: https://github.com/mariusgeorgescu/solana-haskell-sdk diff --git a/src/Network/Solana/Constants.hs b/src/Network/Solana/Constants.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/Constants.hs @@ -0,0 +1,19 @@ +-- | +-- Module : Network.Solana.Constants +-- Description : Useful constants for working with the Solana blockchain. +-- +-- This module provides well-known constants related to Solana's economic model, +-- such as the number of lamports (the smallest unit) in one SOL token. +module Network.Solana.Constants where + +-- | Number of lamports in one SOL. +-- +-- One SOL (the native token of the Solana blockchain) is equal to 1,000,000,000 lamports. +-- Lamports are the smallest indivisible unit of SOL, similar to satoshis in Bitcoin, wei in Ethereum, or lovelaces in Cardano. +lamportsPerSol :: Integer +lamportsPerSol = 1_000_000_000 + +-- | Maximum length in bytes of a single seed used when deriving addresses +-- (program-derived-address seeds and @createAccountWithSeed@ seeds). +maxSeedLen :: Integer +maxSeedLen = 32 diff --git a/src/Network/Solana/Core/Account.hs b/src/Network/Solana/Core/Account.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/Core/Account.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Solana.Core.Account +-- Description : Accounts, account state, and the 'Lamport' unit. +module Network.Solana.Core.Account where + +import Data.Aeson.Types +import Data.ByteString qualified as S +import Data.Text qualified as T +import Data.Vector qualified as V +import Data.Word (Word64) +import GHC.Base (Alternative (..)) +import GHC.Generics (Generic) +import Network.Solana.Constants +import Network.Solana.Core.Crypto +import Text.Printf (printf) + +-- | Lamport is the smallest unit of SOL (1 SOL = 1 billion lamports). +-- 'Show' renders the amount converted to SOL (e.g. @0.000000001 SOL ◎@), not the raw count. +newtype Lamport = Lamport + { -- | The raw lamport amount. + unLamport :: Word64 + } + deriving (Eq, Ord, Generic, Enum) + deriving newtype (Num, Real, Integral) + +instance ToJSON Lamport where + toJSON :: Lamport -> Value + toJSON (Lamport amnt) = toJSON amnt + +instance FromJSON Lamport where + parseJSON :: Value -> Parser Lamport + parseJSON value = do + v <- parseJSON @Word64 value + return $ Lamport v + +instance Show Lamport where + show :: Lamport -> String + show (Lamport n) = + let (sol :: Double) = fromIntegral n / fromIntegral lamportsPerSol + in printf "%.9f SOL ◎" sol + +------------------------------------------------------------------------------------------------ + +-- ** Account + +------------------------------------------------------------------------------------------------ + +-- | An account paired with its address, as returned by RPC methods such as +-- @getProgramAccounts@. +data Account = Account + { -- | The account's address. + pubkey :: SolanaPublicKey, + -- | The account's state. + account :: AccountInfo + } + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +------------------------------------------------------------------------------------------------ + +-- ** Account Info + +------------------------------------------------------------------------------------------------ + +-- | The base state shared by every Solana account. Accounts hold at most +-- 10 MiB of data. +data AccountInfo = AccountInfo + { -- | Amount of lamports in the account + lamports :: Lamport, + -- | The account's data: executable code for program accounts, + -- program-defined state otherwise. Named @dataField@ because @data@ is + -- reserved in Haskell; serialized as @data@ in JSON. + dataField :: AccountData, + -- | The program that owns this account. Only the owner program may + -- modify the account's data or debit its lamports. + owner :: SolanaPublicKey, + -- | A boolean flag that indicates whether this account contains a loaded program. + executable :: Bool + } + deriving (Show, Eq, Generic, ToJSON) + +instance FromJSON AccountInfo where + parseJSON :: Value -> Parser AccountInfo + parseJSON = do + withObject "AccountInfo" $ + \v -> + AccountInfo + <$> v .: "lamports" + <*> v .: "data" + <*> v .: "owner" + <*> v .: "executable" + +------------------------------------------------------------------------------------------------ + +-- ** Account Data + +------------------------------------------------------------------------------------------------ + +-- | A byte array that stores arbitrary data for an account. +data AccountData + = AccountDataBinary + { accData :: S.ByteString + } + | AccountDataJSON {accDataObj :: String} + deriving (Eq, Generic) + +instance Show AccountData where + show :: AccountData -> String + show (AccountDataBinary bs) = toBase58String bs + show (AccountDataJSON o) = show o + +instance ToJSON AccountData where + toJSON :: AccountData -> Value + toJSON ac = toJSON (show ac) + +instance FromJSON AccountData where + parseJSON :: Value -> Parser AccountData + parseJSON v = + let base64StringParser = + withText + "AccountDataText" + (return . AccountDataBinary . fromBase64String . T.unpack) + + base58StringParser = + withText + "AccountDataText" + ( maybe (fail "AccountData: invalid base58") (pure . AccountDataBinary) + . fromBase58String + . T.unpack + ) + + encodedParser = + withArray + "AccountDataArray" + ( \arr -> + if V.length arr /= 2 + then fail "AccountData: expected [data, encoding] pair" + else case arr V.! 1 of + "base58" -> base58StringParser $ arr V.! 0 + "base64" -> base64StringParser $ arr V.! 0 + "json" -> withText "AccountDataJSON" (return . AccountDataJSON . T.unpack) $ arr V.! 0 + "jsonParsed" -> withText "AccountDataJSON" (return . AccountDataJSON . T.unpack) $ arr V.! 0 + other -> fail ("AccountData: unsupported encoding: " <> show other) + ) + v + in base64StringParser v <|> encodedParser diff --git a/src/Network/Solana/Core/Block.hs b/src/Network/Solana/Core/Block.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/Core/Block.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Solana.Core.Block +-- Description : Block hashes and block heights. +module Network.Solana.Core.Block where + +import Network.Solana.Core.Crypto (fromBase58String, toBase58String) +import Data.Aeson.Types +import Data.Binary +import Data.Binary.Get (getByteString) +import Data.Binary.Put (putByteString) +import Data.ByteString qualified as S +import Data.Maybe (fromJust) +import Data.Text qualified as Text +import GHC.Generics (Generic) + +------------------------------------------------------------------------------------------------ + +-- * BlockHash + +------------------------------------------------------------------------------------------------ + +-- | A 32-byte hash identifying a ledger entry (block), rendered in Base58 by +-- 'Show' and the JSON instances. Transactions embed a recent block hash as +-- a proof of recency. +newtype BlockHash = BlockHash S.ByteString + deriving (Eq, Generic) + deriving newtype (Semigroup) + deriving newtype (Monoid) + +instance Show BlockHash where + show :: BlockHash -> String + show (BlockHash bs) = toBase58String bs + +instance Binary BlockHash where + put :: BlockHash -> Put + put (BlockHash bs) = putByteString bs -- not default Binary instance (wo length) + get :: Get BlockHash + get = BlockHash <$> getByteString 32 + +instance ToJSON BlockHash where + toJSON :: BlockHash -> Value + toJSON bh = toJSON (show bh) + +instance FromJSON BlockHash where + parseJSON :: Value -> Parser BlockHash + parseJSON = withText "BlockHash" $ \t -> do + bs <- maybe (fail "BlockHash: invalid base58") pure (fromBase58String (Text.unpack t)) + if S.length bs == 32 + then pure (BlockHash bs) + else fail "BlockHash: expected 32 bytes" + +-- | Build a 'BlockHash' from Base58 text. Calls 'error' if the text is not +-- valid Base58; the decoded length is not checked. +unsafeBlockHash :: String -> BlockHash +unsafeBlockHash = BlockHash . fromJust . fromBase58String + +-- | The number of blocks beneath a block (its height in the chain). +type BlockHeight = Word64 diff --git a/src/Network/Solana/Core/Borsh.hs b/src/Network/Solana/Core/Borsh.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/Core/Borsh.hs @@ -0,0 +1,97 @@ +-- | +-- Module : Network.Solana.Core.Borsh +-- Description : Borsh serialization helpers for common types. +-- +-- This module provides helpers for Borsh serialization, which differs from Bincode +-- in specific length encodings and enum tag widths. Both enforce strict 0/1 validation +-- for Option tags and Bool encoding: +-- +-- * __String lengths__: Borsh uses 32-bit LE (u32), Bincode uses 64-bit LE (u64). +-- * __Vec counts__: Borsh uses 32-bit LE (u32), Bincode uses 64-bit LE (u64). +-- * __Enum tags__: Borsh uses 8-bit (u8), Bincode uses 32-bit LE (u32). +module Network.Solana.Core.Borsh + ( putBorshString, + getBorshString, + putBorshOption, + getBorshOption, + putBorshVec, + getBorshVec, + putBorshBool, + getBorshBool, + ) +where + +import Control.Monad (replicateM) +import Data.Binary.Get (Get, getByteString, getWord32le, getWord8) +import Data.Binary.Put (Put, putByteString, putWord32le, putWord8) +import Data.ByteString qualified as BS +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE + +-- | Serialize a 'String' in Borsh format: u32 LE byte-length + UTF-8 bytes. +-- The length prefix is a 32-bit little-endian word (u32). +putBorshString :: String -> Put +putBorshString s = do + let bs = TE.encodeUtf8 (T.pack s) + putWord32le (fromIntegral (BS.length bs)) + putByteString bs + +-- | Deserialize a 'String' in Borsh format: u32 LE byte-length + UTF-8 bytes. +-- Fails if the length exceeds @maxBound :: Int@ or if the bytes are not valid UTF-8. +getBorshString :: Get String +getBorshString = do + len <- getWord32le + if len > fromIntegral (maxBound :: Int) + then fail "getBorshString: length exceeds Int range" + else do + bs <- getByteString (fromIntegral len) + case TE.decodeUtf8' bs of + Left _ -> fail "getBorshString: invalid UTF-8" + Right t -> pure (T.unpack t) + +-- | Serialize a 'Maybe' value in Borsh format: u8 tag (0 = Nothing, 1 = Just) + optional value. +putBorshOption :: (a -> Put) -> Maybe a -> Put +putBorshOption _ Nothing = putWord8 0 +putBorshOption putVal (Just a) = do + putWord8 1 + putVal a + +-- | Deserialize a 'Maybe' value in Borsh format: u8 tag (0 = Nothing, 1 = Just) + optional value. +-- Fails if the tag is not 0 or 1. +getBorshOption :: Get a -> Get (Maybe a) +getBorshOption getVal = do + tag <- getWord8 + case tag of + 0 -> pure Nothing + 1 -> Just <$> getVal + _ -> fail $ "getBorshOption: invalid tag " <> show tag <> " (expected 0 or 1)" + +-- | Serialize a list in Borsh format: u32 LE count + elements. +putBorshVec :: (a -> Put) -> [a] -> Put +putBorshVec putVal xs = do + putWord32le (fromIntegral (length xs)) + mapM_ putVal xs + +-- | Deserialize a list in Borsh format: u32 LE count + elements. +-- Fails if the count exceeds @maxBound :: Int@. +getBorshVec :: Get a -> Get [a] +getBorshVec getVal = do + count <- getWord32le + if count > fromIntegral (maxBound :: Int) + then fail "getBorshVec: count exceeds Int range" + else replicateM (fromIntegral count) getVal + +-- | Serialize a 'Bool' in Borsh format: u8 (0 = False, 1 = True). +putBorshBool :: Bool -> Put +putBorshBool False = putWord8 0 +putBorshBool True = putWord8 1 + +-- | Deserialize a 'Bool' in Borsh format: u8 (0 = False, 1 = True). +-- Fails if the byte is not 0 or 1. +getBorshBool :: Get Bool +getBorshBool = do + b <- getWord8 + case b of + 0 -> pure False + 1 -> pure True + _ -> fail $ "getBorshBool: invalid byte " <> show b <> " (expected 0 or 1)" diff --git a/src/Network/Solana/Core/Compact.hs b/src/Network/Solana/Core/Compact.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/Core/Compact.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Solana.Core.Compact +-- Description : compact-u16 (ShortU16) encoding and compact arrays. +-- +-- Solana serializes lengths as /compact-u16/: a 'Word16' packed into 1–3 +-- bytes, little-endian, 7 data bits per byte, with the high bit of each +-- byte flagging a continuation byte. The third byte may only carry 2 data +-- bits, and aliased (non-canonical) encodings are rejected when decoding. +-- A 'CompactArray' is a sequence serialized as its compact-u16 length +-- followed by the serialized items. +module Network.Solana.Core.Compact + ( getCompactU16, + putCompactU16, + encodeCompactU16, + decodeCompactU16, + CompactArray (), + mkCompact, + unCompact, + getCompactArrayLength, + ) +where + +import Control.Monad (replicateM) +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import Data.Bits +import Data.ByteString.Lazy qualified as BL +import GHC.Generics + +------------------------------------------------------------------------------------------------ + +-- * CompactArray + +------------------------------------------------------------------------------------------------ + +-- | A list paired with its length, serialized ('Binary' 'put') as a +-- compact-u16 length prefix followed by each item. Build with 'mkCompact'. +data CompactArray a = CompactArray + { -- | The recorded number of items. + getCompactArrayLength :: Word16, + -- | The items of the array. + unCompact :: [a] + } + deriving (Eq, Ord, Show, Generic) + +-- instance (ToJSON a) => ToJSON (CompactArray a) where +-- toJSON :: CompactArray a -> Value +-- toJSON (CompactArray _ xs) = toJSON xs + +-- instance (FromJSON a) => FromJSON (CompactArray a) where +-- parseJSON :: (FromJSON a) => Value -> Parser (CompactArray a) +-- parseJSON v = mkCompact <$> parseJSON v + +instance (Binary a) => Binary (CompactArray a) where + put :: (Binary a) => CompactArray a -> Put + put (CompactArray i xs) = do + putCompactU16 i + mapM_ put xs -- not default putList + get :: (Binary a) => Get (CompactArray a) + get = do + n <- getCompactU16 + xs <- replicateM (fromIntegral n) get + pure (CompactArray n xs) + +-- | Wrap a list into a 'CompactArray', recording its length. The length is +-- truncated to 'Word16'. +mkCompact :: [a] -> CompactArray a +mkCompact xs = CompactArray (fromIntegral $ length xs) xs + +------------------------------------------------------------------------------------------------ + +-- * CompactU16 + +------------------------------------------------------------------------------------------------ + +-- | Decode a compact-u16 value. Fails on encodings longer than 3 bytes, on +-- aliased (non-canonical) encodings, on an invalid third byte, and on +-- values exceeding 'Word16'. +getCompactU16 :: Get Word16 +getCompactU16 = go 0 0 + where + go :: Word32 -> Int -> Get Word16 + go acc byteIndex + | byteIndex >= 3 = fail "Too many bytes in compact-u16" + | otherwise = do + byte <- getWord8 + let value = fromIntegral (byte .&. 0x7F) -- + acc' = acc .|. (value `shiftL` (7 * byteIndex)) + continue = (byte .&. 0x80) /= 0 + if continue + then go acc' (byteIndex + 1) + else + if byteIndex > 0 && byte == 0 + then fail "Aliased (non-canonical) compact-u16 encoding" + else + if byteIndex == 2 && (byte .&. 0xFC) /= 0 + then fail "Invalid 3rd byte in compact-u16 (only 2 bits allowed)" + else case fromIntegral acc' of + w | w <= 0xFFFF -> return w + _ -> fail "Decoded value exceeds u16 range" + +-- | Encode a 'Word16' as compact-u16 (1–3 bytes). +putCompactU16 :: Word16 -> Put +putCompactU16 val = go (fromIntegral val :: Word32) + where + go :: Word32 -> Put + go v + | v < 0x80 = putWord8 (fromIntegral v) + | otherwise = do + putWord8 (fromIntegral (v .&. 0x7F) .|. 0x80) + go (v `shiftR` 7) + +-- | Run 'putCompactU16' to a lazy byte string. +encodeCompactU16 :: Word16 -> BL.ByteString +encodeCompactU16 = runPut . putCompactU16 + +-- | Run 'getCompactU16' over a lazy byte string, returning the decoder's +-- error message on failure. +decodeCompactU16 :: BL.ByteString -> Either String Word16 +decodeCompactU16 bs = + case runGetOrFail getCompactU16 bs of + Left (_, _, err) -> Left err + Right (_, _, val) -> Right val diff --git a/src/Network/Solana/Core/Crypto.hs b/src/Network/Solana/Core/Crypto.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/Core/Crypto.hs @@ -0,0 +1,285 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Solana.Core.Crypto +-- Description : Ed25519 keys, signatures, and Base58\/Base64 helpers for Solana. +-- +-- Wrappers around "Crypto.Sign.Ed25519" providing the core cryptographic +-- types: 'SolanaPublicKey', 'SolanaPrivateKey' and 'SolanaSignature'. +-- All three 'show' as the Base58 strings used across the Solana ecosystem. +module Network.Solana.Core.Crypto + ( createSolanaKeyPair, + createSolanaKeypairFromSeed, + toSolanaPublicKey, + sign, + verify, + dsign, + dverify, + SolanaPublicKey, + SolanaPrivateKey, + SolanaSignature, + unsafeSolanaPublicKey, + unsafeSolanaPublicKeyRaw, + unsafeSolanaPrivateKey, + unsafeSolanaPrivateKeyRaw, + unsafeSigFromString, + getSolanaPublicKeyRaw, + getSolanaPrivateKeyRaw, + getSolanaSignatureRaw, + toBase58String, + toBase64String, + fromBase64String, + fromBase58String, + readSigningKeyFromFile, + mkPublicKeyFromString, + mkPrivateKeyFromString, + ) +where + +import Crypto.Sign.Ed25519 qualified as Ed25519 +import Data.Aeson +import Data.Aeson.Types +import Data.Bifunctor (Bifunctor (bimap)) +import Data.Binary +import Data.Binary.Get (getByteString) +import Data.Binary.Put (putByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Base58 +import Data.ByteString.Base64 (decodeBase64Lenient, encodeBase64') +import Data.ByteString.Char8 qualified as BS8 +import Data.Either.Extra (maybeToEither) +import Data.String (IsString, fromString) +import Data.Text qualified as Text +import GHC.Generics (Generic) +import Text.Read (readMaybe) + +-- | Encode a byte string as Base58 text (Bitcoin alphabet), the encoding +-- Solana uses for addresses, signatures and hashes. +toBase58String :: BS.ByteString -> String +toBase58String = tail . init . show . encodeBase58 bitcoinAlphabet + +-- | Encode a byte string as Base64 text. +toBase64String :: BS.ByteString -> String +toBase64String = tail . init . show . encodeBase64' + +-- | Decode Base58 text (Bitcoin alphabet); 'Nothing' if the input contains +-- characters outside the alphabet. +fromBase58String :: String -> Maybe BS.ByteString +fromBase58String = decodeBase58 bitcoinAlphabet . fromString + +-- | Decode Base64 text /leniently/: invalid characters are skipped rather +-- than reported, so this never fails but may silently accept malformed +-- input. +fromBase64String :: String -> BS.ByteString +fromBase64String = decodeBase64Lenient . fromString + +--- >>> fromBase64String $ toBase64String "Sun" +--- >>> fromBase58String $ toBase58String "Sun" +-- "Sun" +-- Just "Sun" + +------------------------------------------------------------------------------------------------ + +-- * SolanaSignature + +------------------------------------------------------------------------------------------------ + +-- | A 64-byte detached Ed25519 signature. 'Show' and the JSON instances use +-- the Base58 rendering. +newtype SolanaSignature = SolanaSignature Ed25519.Signature + deriving (Eq, Ord, Generic) + +instance Show SolanaSignature where + show :: SolanaSignature -> String + show (SolanaSignature (Ed25519.Signature bs)) = toBase58String bs + +instance Binary SolanaSignature where + put :: SolanaSignature -> Put + put (SolanaSignature (Ed25519.Signature bs)) = putByteString bs + get :: Get SolanaSignature + get = SolanaSignature . Ed25519.Signature <$> getByteString 64 + +instance ToJSON SolanaSignature where + toJSON :: SolanaSignature -> Value + toJSON pk = toJSON (show pk) + +instance FromJSON SolanaSignature where + parseJSON :: Value -> Parser SolanaSignature + parseJSON = withText "SolanaSignature" $ either fail pure . mkSigFromString . Text.unpack + +------------------------------------------------------------------------------------------------ + +-- *** SolanaPublicKey + +------------------------------------------------------------------------------------------------ + +-- | A 32-byte Ed25519 public key: the address of an account, program or +-- signer. 'Show' and the JSON instances use the Base58 rendering; the +-- 'IsString' instance is partial (see 'unsafeSolanaPublicKey'). +newtype SolanaPublicKey + = SolanaPublicKey Ed25519.PublicKey + deriving (Eq, Ord, Generic) + +instance Show SolanaPublicKey where + show :: SolanaPublicKey -> String + show (SolanaPublicKey (Ed25519.PublicKey bs)) = toBase58String bs + +instance IsString SolanaPublicKey where + fromString = unsafeSolanaPublicKey + +instance Binary SolanaPublicKey where + put :: SolanaPublicKey -> Put + put (SolanaPublicKey (Ed25519.PublicKey bs)) = putByteString bs + get :: Get SolanaPublicKey + get = SolanaPublicKey . Ed25519.PublicKey <$> getByteString 32 + +instance ToJSON SolanaPublicKey where + toJSON :: SolanaPublicKey -> Value + toJSON pk = toJSON (show pk) + +instance FromJSON SolanaPublicKey where + parseJSON :: Value -> Parser SolanaPublicKey + parseJSON = withText "SolanaPublicKey" $ either fail pure . mkPublicKeyFromString . Text.unpack + +instance FromJSONKey SolanaPublicKey where + fromJSONKey :: FromJSONKeyFunction SolanaPublicKey + fromJSONKey = FromJSONKeyTextParser (either fail pure . mkPublicKeyFromString . Text.unpack) + +instance ToJSONKey SolanaPublicKey where + toJSONKey :: ToJSONKeyFunction SolanaPublicKey + toJSONKey = toJSONKeyText (Text.pack . show) + +------------------------------------------------------------------------------------------------ + +-- *** SolanaPrivateKey + +------------------------------------------------------------------------------------------------ + +-- | A 64-byte Ed25519 secret key (seed plus public key, NaCl layout). +-- 'Show' renders it in Base58 — avoid logging values of this type. +newtype SolanaPrivateKey + = SolanaPrivateKey Ed25519.SecretKey + deriving (Eq, Ord, Generic) + +instance Show SolanaPrivateKey where + show :: SolanaPrivateKey -> String + show (SolanaPrivateKey (Ed25519.SecretKey bs)) = toBase58String bs + +------------------------------------------------------------------------------------------------ + +-- *** Functions + +------------------------------------------------------------------------------------------------ + +mkSigFromString :: String -> Either String SolanaSignature +mkSigFromString str = do + bs <- maybeToEither "Not base58" $ fromBase58String str + if BS.length bs == 64 + then Right $ (SolanaSignature . Ed25519.Signature) bs + else Left "Invalid string length for sig" + +-- | Build a 'SolanaSignature' from Base58 text. Calls 'error' unless the +-- input decodes to exactly 64 bytes. +unsafeSigFromString :: String -> SolanaSignature +unsafeSigFromString = either error id . mkSigFromString + +mkKeyFromString :: forall f. Int -> (BS.ByteString -> f) -> String -> Either String f +mkKeyFromString n cstr str = do + bs <- maybeToEither "Not base58" $ fromBase58String str + if BS.length bs == n + then Right $ cstr bs + else Left "Invalid string length for key" + +-- | Parse Base58 text into a 'SolanaPublicKey'. 'Left' if the input is not +-- Base58 or does not decode to exactly 32 bytes. +mkPublicKeyFromString :: String -> Either String SolanaPublicKey +mkPublicKeyFromString = mkKeyFromString 32 (SolanaPublicKey . Ed25519.PublicKey) + +-- | Parse Base58 text into a 'SolanaPrivateKey'. 'Left' if the input is not +-- Base58 or has the wrong length. +mkPrivateKeyFromString :: String -> Either String SolanaPrivateKey +mkPrivateKeyFromString = mkKeyFromString 64 (SolanaPrivateKey . Ed25519.SecretKey) + +unsafeKeyFromString :: forall f. Int -> (BS.ByteString -> f) -> String -> f +unsafeKeyFromString n cstr str = either error id $ mkKeyFromString n cstr str + +unsafeKeyFromWords :: forall f. (BS.ByteString -> f) -> [Word8] -> f +unsafeKeyFromWords cstr ws = cstr (BS.pack ws) + +-- | Partial version of 'mkPublicKeyFromString': calls 'error' on invalid +-- input. Prefer the total variant outside of literals and tests. +unsafeSolanaPublicKey :: String -> SolanaPublicKey +unsafeSolanaPublicKey = unsafeKeyFromString 32 (SolanaPublicKey . Ed25519.PublicKey) + +-- | Build a 'SolanaPublicKey' directly from raw bytes. No length check is +-- performed — the caller must supply exactly 32 bytes. +unsafeSolanaPublicKeyRaw :: [Word8] -> SolanaPublicKey +unsafeSolanaPublicKeyRaw = unsafeKeyFromWords (SolanaPublicKey . Ed25519.PublicKey) + +-- | Partial version of 'mkPrivateKeyFromString': calls 'error' on invalid +-- input. +unsafeSolanaPrivateKey :: String -> SolanaPrivateKey +unsafeSolanaPrivateKey = unsafeKeyFromString 64 (SolanaPrivateKey . Ed25519.SecretKey) + +-- | Build a 'SolanaPrivateKey' directly from raw bytes (e.g. the 64 numbers +-- in a @solana-keygen@ keypair file). No length check is performed. +unsafeSolanaPrivateKeyRaw :: [Word8] -> SolanaPrivateKey +unsafeSolanaPrivateKeyRaw = unsafeKeyFromWords (SolanaPrivateKey . Ed25519.SecretKey) + +-- | The raw 32 bytes of a public key. +getSolanaPublicKeyRaw :: SolanaPublicKey -> BS.ByteString +getSolanaPublicKeyRaw (SolanaPublicKey (Ed25519.PublicKey bs)) = bs + +-- | The raw bytes of a secret key. Handle with care. +getSolanaPrivateKeyRaw :: SolanaPrivateKey -> BS.ByteString +getSolanaPrivateKeyRaw (SolanaPrivateKey (Ed25519.SecretKey bs)) = bs + +-- | The raw 64 bytes of a signature. +getSolanaSignatureRaw :: SolanaSignature -> BS.ByteString +getSolanaSignatureRaw (SolanaSignature (Ed25519.Signature bs)) = bs + +-- | Generate a fresh random Ed25519 keypair. +createSolanaKeyPair :: IO (SolanaPublicKey, SolanaPrivateKey) +createSolanaKeyPair = bimap SolanaPublicKey SolanaPrivateKey <$> Ed25519.createKeypair + +-- | Derive a keypair deterministically from a seed. 'Nothing' unless the +-- seed is exactly 32 bytes. +createSolanaKeypairFromSeed :: BS.ByteString -> Maybe (SolanaPublicKey, SolanaPrivateKey) +createSolanaKeypairFromSeed bs = bimap SolanaPublicKey SolanaPrivateKey <$> Ed25519.createKeypairFromSeed_ bs + +-- | The public key corresponding to a private key. +toSolanaPublicKey :: SolanaPrivateKey -> SolanaPublicKey +toSolanaPublicKey (SolanaPrivateKey pv) = SolanaPublicKey $ Ed25519.toPublicKey pv + +-- | Sign a message, returning the /joined/ signed message (signature +-- prepended to the message). For transaction signatures use 'dsign'. +sign :: SolanaPrivateKey -> BS.ByteString -> BS.ByteString +sign (SolanaPrivateKey sk) = Ed25519.sign sk + +-- | Verify a joined signed message produced by 'sign'. +verify :: SolanaPublicKey -> BS.ByteString -> Bool +verify (SolanaPublicKey pk) = Ed25519.verify pk + +-- | Produce a detached 'SolanaSignature' over a byte string. This is the +-- primitive used to sign transaction messages. +dsign :: SolanaPrivateKey -> BS.ByteString -> SolanaSignature +dsign (SolanaPrivateKey sk) bs = SolanaSignature $ Ed25519.dsign sk bs + +-- | Verify a detached 'SolanaSignature' over a byte string. +dverify :: SolanaPublicKey -> BS.ByteString -> SolanaSignature -> Bool +dverify (SolanaPublicKey pk) bs (SolanaSignature sig) = Ed25519.dverify pk bs sig + +---- +---- +---- +---- + +-- | Read a private key from a @solana-keygen@-style keypair file containing +-- a list of byte values (e.g. @[1,2,...]@). Throws an 'IOError' if the file +-- cannot be read, or if its contents cannot be parsed as a @[Word8]@ list. +readSigningKeyFromFile :: FilePath -> IO SolanaPrivateKey +readSigningKeyFromFile path = do + contents <- BS8.readFile path + case readMaybe (BS8.unpack contents) of + Just word8List -> return $ unsafeSolanaPrivateKeyRaw (word8List :: [Word8]) + Nothing -> fail ("readSigningKeyFromFile: could not parse " <> path <> " as a list of bytes (e.g. \"[1,2,...]\")") diff --git a/src/Network/Solana/Core/Instruction.hs b/src/Network/Solana/Core/Instruction.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/Core/Instruction.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Network.Solana.Core.Instruction + ( Instruction, + mkInstruction, + iProgramId, + iAccounts, + iData, + AccountMeta (..), + InstructionData (..), + compileInstruction, + CompiledInstruction, + CompileException (..), + ) +where + +import Control.Exception +import Data.Aeson.Types +import Data.Binary +import Data.Binary qualified as Binary +import Data.ByteString qualified as S +import Data.Either.Combinators +import Data.List (elemIndex) +import GHC.Generics (Generic) +import Network.Solana.Core.Compact +import Network.Solana.Core.Crypto (SolanaPublicKey, fromBase58String, toBase58String, toBase64String) + +------------------------------------------------------------------------------------------------ + +-- * Instruction + +------------------------------------------------------------------------------------------------ + +-- | A single program invocation: which program to call, the accounts it +-- may read or write, and the input bytes to pass it. +data Instruction = Instruction + { -- | Address of the program that executes this instruction. + iProgramId :: SolanaPublicKey, + -- | List of metadata describing accounts that should be passed to the program. + iAccounts :: [AccountMeta], + -- | Bytes selecting which instruction of the program to invoke, plus + -- any arguments it needs. + iData :: InstructionData + } + deriving (Show, Eq, Generic) + +-- | Build an 'Instruction' from a program id, account metas, and +-- 'Binary'-encodable instruction data. +mkInstruction :: (Binary.Binary a) => SolanaPublicKey -> [AccountMeta] -> a -> Instruction +mkInstruction programid accmetas instrData = + Instruction + { iProgramId = programid, + iAccounts = accmetas, + iData = InstructionData $ S.toStrict (Binary.encode instrData) + } + +------------------------------------------------------------------------------------------------ + +-- ** Account Meta + +------------------------------------------------------------------------------------------------ + +-- | Each account required by an instruction must be provided as an AccountMeta that contains: +data AccountMeta = AccountMeta + { -- | Account's address + accountPubKey :: SolanaPublicKey, + {- Whether the account must sign the transaction. + True if an 'Instruction' requires a 'Transaction' signature matching 'SolanaPublicKey'. + -} + isSigner :: Bool, + {- Whether the instruction will modify the account's data. + True if the account data or metadata may be mutated during program execution. + -} + isWritable :: Bool + } + deriving (Show, Eq, Generic) + +------------------------------------------------------------------------------------------------ + +-- ** Instruction Data + +------------------------------------------------------------------------------------------------ + +-- | Raw instruction input bytes. 'Show' renders them in Base64. +newtype InstructionData = InstructionData {instrData :: S.ByteString} + deriving (Eq, Generic) + +instance Show InstructionData where + show :: InstructionData -> String + show (InstructionData bs) = toBase64String bs + +------------------------------------------------------------------------------------------------ + +-- *** Compiled Instruction + +------------------------------------------------------------------------------------------------ + +-- | The structure of a compiled instruction. +data CompiledInstruction = CompiledInstruction + { {- + Index that points to the program's address in the account addresses array. + This specifies the program that will process the instruction. + -} + ciProgramIdIndex :: Word8, + -- | Compact array of indexes that point to the account addresses required for this instruction. + ciAccounts :: CompactArray Word8, + {- Compact byte array specifying the instruction on the program to invoke + and any function arguments required by the instruction. + -} + ciData :: CompactArray Word8 + } + deriving (Show, Eq, Generic) + +instance ToJSON CompiledInstruction where + toJSON :: CompiledInstruction -> Value + toJSON (CompiledInstruction programIdIndex accounts iData) = + object + [ "programIdIndex" .= programIdIndex, + "accounts" .= unCompact accounts, + "data" .= (toBase58String . S.pack . unCompact $ iData) + ] + +instance FromJSON CompiledInstruction where + parseJSON :: Value -> Parser CompiledInstruction + parseJSON = withObject "CompiledInstruction" $ \v -> do + programIdIndex <- v .: "programIdIndex" + accounts <- v .: "accounts" + dataStr <- v .: "data" + bytes <- case fromBase58String dataStr of + Nothing -> fail "CompiledInstruction: data is not valid base58" + Just bs -> pure bs + pure + CompiledInstruction + { ciProgramIdIndex = programIdIndex, + ciAccounts = mkCompact accounts, + ciData = mkCompact (S.unpack bytes) + } + +instance Binary CompiledInstruction where + put :: CompiledInstruction -> Put + put CompiledInstruction {..} = do + put ciProgramIdIndex + put ciAccounts + put ciData + get :: Get CompiledInstruction + get = CompiledInstruction <$> get <*> get <*> get + +-- | Replace each pubkey referenced by an instruction with its index into +-- the given account-key table. 'Left' when a key is not present in the +-- table. +compileInstruction :: [SolanaPublicKey] -> Instruction -> Either CompileException CompiledInstruction +compileInstruction keys instruction = do + programIdIndex <- keyToIndex (iProgramId instruction) keys + accIndices <- mapM ((`keyToIndex` keys) . accountPubKey) (iAccounts instruction) + return $ + CompiledInstruction + { ciProgramIdIndex = fromIntegral programIdIndex, + ciAccounts = mkCompact (fromIntegral <$> accIndices), + ciData = mkCompact . S.unpack $ instrData (iData instruction) + } + +keyToIndex :: SolanaPublicKey -> [SolanaPublicKey] -> Either CompileException Int +keyToIndex k keys = maybeToRight (MissingIndex $ show k) $ k `elemIndex` keys + +------------------------------------------------------------------------------------------------ + +-- *** CompileException + +------------------------------------------------------------------------------------------------ +-- | Compilation failure: an instruction references an account key that is +-- missing from the message's account table. +newtype CompileException = MissingIndex String + deriving (Show) + +instance Exception CompileException diff --git a/src/Network/Solana/Core/Message.hs b/src/Network/Solana/Core/Message.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/Core/Message.hs @@ -0,0 +1,384 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Network.Solana.Core.Message +-- Description : Building, canonically ordering, compiling and signing transaction messages. +module Network.Solana.Core.Message + ( newTransactionIntent, + newTransactionIntentWithPayer, + newDurableNonceTransactionIntent, + newDurableNonceTransactionIntentWithPayer, + SignedTransactionIntent, + Message (..), + MessageHeader (..), + CompiledMessage, + newMessage, + newMessageToBase64String, + mkNewMessage, + ) +where + +import Data.Aeson +import Data.Aeson.Types (Parser) +import Data.Binary +import Data.ByteString qualified as S +import Data.Foldable +import Data.List (sortOn) +import GHC.Generics (Generic) +import Network.Solana.Core.Block (BlockHash) +import Network.Solana.Core.Compact +import Network.Solana.Core.Crypto (SolanaPrivateKey, SolanaPublicKey, dsign, getSolanaPublicKeyRaw, toBase64String, toSolanaPublicKey) +import Network.Solana.Core.Instruction +import Network.Solana.NativePrograms.SystemProgram qualified as SystemProgram + + +------------------------------------------------------------------------------------------------ + +-- * SignedTransactionIntent + +------------------------------------------------------------------------------------------------ + +-- | A transaction awaiting a recent block hash: applying one yields the +-- Base64-encoded signed transaction, or a 'CompileException'. +type SignedTransactionIntent = (BlockHash -> Either CompileException String) + + +-- | Builds and signs a transaction from a list of signing keys and +-- instructions. The fee payer is the first writable signer encountered +-- across the instructions' account metas, and account keys are canonically +-- ordered (fee payer first, then each privilege section sorted by pubkey +-- bytes; see @canonicalizeAccountOrder@). The private keys passed here must +-- be ordered to match the resulting account order (fee payer first), +-- otherwise the produced signatures will not correspond to the right +-- account keys. If you would rather name the fee payer explicitly and not +-- worry about signer order, consider 'newTransactionIntentWithPayer', +-- which orders signatures automatically. +newTransactionIntent :: [SolanaPrivateKey] -> [Instruction] -> SignedTransactionIntent +newTransactionIntent signers instructions blockhash = do + msg <- newMessage blockhash instructions -- make the binary message + let signatures = S.toStrict . Data.Binary.encode $ mkCompact $ flip dsign msg <$> signers -- sign the binary message + return $ toBase64String $ S.append signatures msg -- return signed transaction + +-- | Builds and signs a transaction with an explicitly named fee payer. +-- Unlike 'newTransactionIntent', the fee payer is always account 0 +-- (sponsored fees are supported: the payer need not appear in any +-- instruction at all), and the given private keys may be listed in any +-- order — they are matched against the compiled message's required +-- signers and the resulting signatures are placed in message order +-- automatically. 'Left' if a required signer has no corresponding private +-- key, or if a given private key does not correspond to any required +-- signer. Duplicate private keys for the same required signer are +-- tolerated: the first match signs, mirroring the Rust SDK's @try_sign@. +newTransactionIntentWithPayer :: SolanaPublicKey -> [SolanaPrivateKey] -> [Instruction] -> BlockHash -> Either CompileException String +newTransactionIntentWithPayer payer signingKeys instructions blockhash = do + let msg = mkNewMessageWithPayer payer blockhash instructions + msgBytes <- compileMessageToBinary msg + let requiredSigners = take (fromIntegral (numRequiredSignatures (mHeader msg))) (mAccountKeys msg) + keyedByPubkey = [(toSolanaPublicKey k, k) | k <- signingKeys] + orderedKeys <- mapM (findSigningKey keyedByPubkey) requiredSigners + mapM_ (checkKeyIsRequired requiredSigners . fst) keyedByPubkey + let signatures = S.toStrict . Data.Binary.encode $ mkCompact $ flip dsign msgBytes <$> orderedKeys + return $ toBase64String $ S.append signatures msgBytes + where + findSigningKey keyedByPubkey pk = + case lookup pk keyedByPubkey of + Just k -> Right k + Nothing -> Left (MissingIndex ("missing signer for " <> show pk)) + checkKeyIsRequired requiredSigners pk = + if pk `elem` requiredSigners + then Right () + else Left (MissingIndex ("unused signing key " <> show pk)) + +-- | Builds and signs a durable-nonce transaction: prepends +-- @SystemProgram.advanceNonceAccount nonceAccount nonceAuthority@ ahead of +-- the given instructions and delegates to 'newTransactionIntent'. The +-- durable nonce — read from the nonce account's on-chain 'Network.Solana.NativePrograms.SystemProgram.NonceState' via +-- @nsDurableNonce@ — is passed in place of a recent block hash, since a +-- durable-nonce transaction never expires and does not depend on a recent +-- ledger entry. The nonce authority must be among the given signers, or the +-- resulting transaction will be rejected on submission. +-- +-- ORDER-SENSITIVE: as with 'newTransactionIntent', the given private keys +-- must be ordered to match the resulting canonical account order (fee payer +-- first), or the produced signatures will not correspond to the right +-- account keys. If you would rather name the fee payer explicitly and not +-- worry about signer order, use 'newDurableNonceTransactionIntentWithPayer' +-- instead. +newDurableNonceTransactionIntent :: [SolanaPrivateKey] -> SolanaPublicKey -> SolanaPublicKey -> [Instruction] -> BlockHash -> Either CompileException String +newDurableNonceTransactionIntent signers nonceAccount nonceAuthority instructions = + newTransactionIntent signers (SystemProgram.advanceNonceAccount nonceAccount nonceAuthority : instructions) + +-- | Builds and signs a durable-nonce transaction with an explicitly named +-- fee payer: prepends @SystemProgram.advanceNonceAccount nonceAccount +-- nonceAuthority@ ahead of the given instructions and delegates to +-- 'newTransactionIntentWithPayer', composing sponsored fees with durable +-- nonces. As with 'newTransactionIntentWithPayer', the fee payer is forced +-- into account 0 (even if it appears in no instruction), and the given +-- private keys may be listed in any order — signatures are auto-ordered to +-- match the compiled message. The nonce authority must be among the given +-- signers, or the resulting transaction will be rejected on submission. +newDurableNonceTransactionIntentWithPayer :: SolanaPublicKey -> [SolanaPrivateKey] -> SolanaPublicKey -> SolanaPublicKey -> [Instruction] -> BlockHash -> Either CompileException String +newDurableNonceTransactionIntentWithPayer payer signers nonceAccount nonceAuthority instructions = + newTransactionIntentWithPayer payer signers (SystemProgram.advanceNonceAccount nonceAccount nonceAuthority : instructions) + +------------------------------------------------------------------------------------------------ + +-- ** Message + +------------------------------------------------------------------------------------------------ + +-- | The structure of a transaction message. +data Message = Message + { -- | Specifies the number of signer and read-only account. + mHeader :: MessageHeader, + -- | All the account keys used by this transaction (used by all the instructions on the transaction). + mAccountKeys :: [SolanaPublicKey], + -- | The id of a recent ledger entry. Acts as a timestamp for the transaction. + mRecentBlockhash :: BlockHash, + {- An array of instructions to be executed. + Programs that will be executed in sequence and committed in one atomic transaction if all succeed. + -} + mInstructions :: [Instruction] + } + deriving (Show, Eq, Generic) + +-- | Compile instructions into serialized legacy-message bytes using the +-- given recent block hash. Account keys are collected and canonically +-- ordered as described at 'newTransactionIntent'. +newMessage :: BlockHash -> [Instruction] -> Either CompileException S.ByteString +newMessage bh is = compileMessageToBinary (mkNewMessage bh is) + +-- | Like 'newMessage', but returns the message bytes Base64-encoded. +newMessageToBase64String :: BlockHash -> [Instruction] -> Either CompileException String +newMessageToBase64String = fmap (fmap toBase64String) . newMessage + +compileMessageToBinary :: Message -> Either CompileException S.ByteString +compileMessageToBinary = fmap (S.toStrict . Data.Binary.encode) . compileMessage + +-- | Assemble the uncompiled 'Message': fold the instructions' account +-- metas into a deduplicated, privilege-merged key list, then put it in +-- canonical order. +mkNewMessage :: BlockHash -> [Instruction] -> Message +mkNewMessage bh = + canonicalizeAccountOrder . updateMessageWithInstructions (Message mempty mempty bh mempty) + +-- | Like 'mkNewMessage', but with an explicitly named fee payer. The payer +-- is seeded as a writable signer before the instructions' account metas are +-- folded in, so it ends up in the message (and pinned first by +-- 'canonicalizeAccountOrder') even if no instruction references it — +-- enabling sponsored-fee transactions. +mkNewMessageWithPayer :: SolanaPublicKey -> BlockHash -> [Instruction] -> Message +mkNewMessageWithPayer payer bh = + canonicalizeAccountOrder . updateMessageWithInstructions seeded + where + payerMeta = AccountMeta {accountPubKey = payer, isSigner = True, isWritable = True} + (seededHeader, seededKeys) = updateHeaderAndKeys (mempty, mempty) payerMeta + seeded = Message seededHeader seededKeys bh mempty + +-- | Sort the account keys within each privilege section by raw pubkey bytes, +-- keeping the fee payer (first writable signer) pinned in first position. +-- Matches the Rust SDK's CompiledKeys (BTreeMap) ordering, which is required +-- for byte-identical messages once several program ids share a section. +canonicalizeAccountOrder :: Message -> Message +canonicalizeAccountOrder (Message header keys bh instrs) = + let (rws, ros, rwus, rous) = splitAccountsByPurpose header keys + sortKeys = sortOn getSolanaPublicKeyRaw + rws' = case rws of + [] -> [] + (feePayer : rest) -> feePayer : sortKeys rest + keys' = rws' <> sortKeys ros <> sortKeys rwus <> sortKeys rous + in Message header keys' bh instrs + +updateMessageWithInstructions :: Message -> [Instruction] -> Message +updateMessageWithInstructions = foldl' updateMessageWithInstruction + +updateMessageWithInstruction :: Message -> Instruction -> Message +updateMessageWithInstruction (Message header accountKeys bh instrs) newInstr = + let programMeta = + AccountMeta + { accountPubKey = iProgramId newInstr, + isSigner = False, + isWritable = False + } + (newHeader, newAccountKeys) = + foldl' updateHeaderAndKeys (header, accountKeys) (iAccounts newInstr <> [programMeta]) + newInstrucionsList = instrs <> [newInstr] + in Message newHeader newAccountKeys bh newInstrucionsList + +updateHeaderAndKeys :: (MessageHeader, [SolanaPublicKey]) -> AccountMeta -> (MessageHeader, [SolanaPublicKey]) +updateHeaderAndKeys (currentHeader, currentKeys) (AccountMeta newKey isSigner isWritable) = + let (rws, ros, rwus, rous) = splitAccountsByPurpose currentHeader currentKeys + alreadySignable = newKey `elem` rws <> ros + alreadyWritable = newKey `elem` rws <> rwus + (rws', ros', rwus', rous') = + case (isSigner || alreadySignable, isWritable || alreadyWritable) of + (True, True) -> + ( addIfNotExists newKey rws, + removeAll newKey ros, + removeAll newKey rwus, + removeAll newKey rous + ) + (True, False) -> + ( rws, + addIfNotExists newKey ros, + rwus, + removeAll newKey rous + ) + (False, True) -> + ( rws, + ros, + addIfNotExists newKey rwus, + removeAll newKey rous + ) + (False, False) -> + ( rws, + ros, + rwus, + addIfNotExists newKey rous + ) + updatedMessage = mkMessageHeaderFromSplittedAccounts (rws', ros', rwus', rous') + updatedKeys = (rws' <> ros' <> rwus' <> rous') + in (updatedMessage, updatedKeys) + where + addIfNotExists :: (Eq a) => a -> [a] -> [a] + addIfNotExists x xs = + if x `elem` xs + then xs + else xs ++ [x] + + removeAll :: (Eq a) => a -> [a] -> [a] + removeAll x = filter (/= x) + +splitAccountsByPurpose :: + MessageHeader -> + [SolanaPublicKey] -> + ([SolanaPublicKey], [SolanaPublicKey], [SolanaPublicKey], [SolanaPublicKey]) +splitAccountsByPurpose + (MessageHeader x y z) + keys = + let numRequiredSignatures = fromIntegral x + numReadonlySigned = fromIntegral y + numReadonlyUnsigned = fromIntegral z + + -- Split into signed and unsigned keys: + (signed, unsigned) = splitAt numRequiredSignatures keys + -- For signed keys: first part are read and write, last part are read-only. + (readAndWriteSigned, readOnlySigned) = splitAt (numRequiredSignatures - numReadonlySigned) signed + -- For unsigned keys: + unsignedCount = length unsigned + (readAndWriteUnsigned, readOnlyUnsigned) = splitAt (unsignedCount - numReadonlyUnsigned) unsigned + in (readAndWriteSigned, readOnlySigned, readAndWriteUnsigned, readOnlyUnsigned) + +mkMessageHeaderFromSplittedAccounts :: + ([SolanaPublicKey], [SolanaPublicKey], [SolanaPublicKey], [SolanaPublicKey]) -> + MessageHeader +mkMessageHeaderFromSplittedAccounts (readAndWriteSigned, readOnlySigned, _readAndWriteUnsigned, readOnlyUnsigned) = + let numRequiredSignatures = fromIntegral $ length readAndWriteSigned + length readOnlySigned + numReadonlySigned = fromIntegral $ length readOnlySigned + numReadonlyUnsigned = fromIntegral $ length readOnlyUnsigned + in MessageHeader numRequiredSignatures numReadonlySigned numReadonlyUnsigned + +------------------------------------------------------------------------------------------------ + +-- *** MessageHeader + +------------------------------------------------------------------------------------------------ +-- | Three bytes at the front of every message declaring account privileges. +data MessageHeader = MessageHeader + { -- | Number of signatures required for the message to be valid; the + -- first @numRequiredSignatures@ account keys of the message must sign, + -- in order. + numRequiredSignatures :: Word8, + -- | Of the signed keys, the last @numReadonlySignedAccounts@ are + -- read-only. + numReadonlySignedAccounts :: Word8, + -- | Of the unsigned keys, the last @numReadonlyUnsignedAccounts@ are + -- read-only. + numReadonlyUnsignedAccounts :: Word8 + } + deriving (Show, Eq, Generic) + deriving anyclass (ToJSON, FromJSON) + +instance Binary MessageHeader where + put :: MessageHeader -> Put + put MessageHeader {..} = do + put numRequiredSignatures + put numReadonlySignedAccounts + put numReadonlyUnsignedAccounts + + get :: Get MessageHeader + get = MessageHeader <$> get <*> get <*> get + +instance Semigroup MessageHeader where + (<>) :: MessageHeader -> MessageHeader -> MessageHeader + (<>) (MessageHeader rqs ros rou) (MessageHeader rqs' ros' rou') = MessageHeader (rqs + rqs') (ros + ros') (rou + rou') + +instance Monoid MessageHeader where + mempty :: MessageHeader + mempty = MessageHeader 0 0 0 + +------------------------------------------------------------------------------------------------ + +-- ** Compiled Message + +------------------------------------------------------------------------------------------------ + +-- | The structure of a Compiled Message. +data CompiledMessage = CompiledMessage + { -- | Specifies the number of signer and read-only account. + cmHeader :: MessageHeader, + -- | Compact array of account keys used by this transaction (used by all the instructions on the transaction). + cmAccountKeys :: CompactArray SolanaPublicKey, + -- | The id of a recent ledger entry. Acts as a timestamp for the transaction. + cmRecentBlockhash :: BlockHash, + {- Compact array of compiled instructions to be executed. + -} + cmInstructions :: CompactArray CompiledInstruction + } + deriving (Show, Eq, Generic) + +instance ToJSON CompiledMessage where + toJSON :: CompiledMessage -> Value + toJSON (CompiledMessage header accountKeys recentBlockhash instructions) = + object + [ "header" .= header, + "accountKeys" .= unCompact accountKeys, + "recentBlockhash" .= recentBlockhash, + "instructions" .= unCompact instructions + ] + +instance FromJSON CompiledMessage where + parseJSON :: Value -> Parser CompiledMessage + parseJSON = withObject "CompiledMessage" $ \v -> + CompiledMessage + <$> v .: "header" + <*> (mkCompact <$> (v .: "accountKeys")) + <*> v .: "recentBlockhash" + <*> (mkCompact <$> (v .: "instructions")) + +instance Binary CompiledMessage where + put :: CompiledMessage -> Put + put CompiledMessage {..} = do + put cmHeader + put cmAccountKeys + put cmRecentBlockhash + put cmInstructions + +------------------------------------------------------------------------------------------------ + +-- *** Compile Message + +------------------------------------------------------------------------------------------------ +compileMessage :: Message -> Either CompileException CompiledMessage +compileMessage Message {..} = do + compiledInstrctions <- mapM (compileInstruction mAccountKeys) mInstructions + return $ + CompiledMessage + { cmHeader = mHeader, + cmAccountKeys = mkCompact mAccountKeys, + cmRecentBlockhash = mRecentBlockhash, + cmInstructions = mkCompact compiledInstrctions + } diff --git a/src/Network/Solana/Core/Pda.hs b/src/Network/Solana/Core/Pda.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/Core/Pda.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Program Derived Addresses (PDAs): addresses derived from seeds and a +-- program id that are guaranteed to lie off the ed25519 curve, so no +-- private key can exist for them. Used by programs to sign via CPI and by +-- clients to locate program-owned accounts (e.g. associated token accounts). +module Network.Solana.Core.Pda + ( PdaError (..), + createProgramAddress, + findProgramAddress, + ) +where + +import Crypto.ECC.Edwards25519 qualified as Edwards +import Crypto.Error (CryptoFailable (..)) +import Crypto.Hash (Digest, SHA256, hash) +import Data.ByteArray qualified as BA +import Data.ByteString qualified as BS +import Data.Word (Word8) +import Network.Solana.Core.Crypto (SolanaPublicKey, getSolanaPublicKeyRaw, unsafeSolanaPublicKeyRaw) + +data PdaError + = -- | A seed exceeds 32 bytes + SeedTooLong + | -- | More than 16 seeds were provided + TooManySeeds + | -- | The derived hash landed on the ed25519 curve; use another bump/seed + InvalidSeeds + deriving (Eq, Show) + +pdaMarker :: BS.ByteString +pdaMarker = "ProgramDerivedAddress" + +-- | Derive a program address from seeds and a program id. Fails with +-- 'InvalidSeeds' if the sha256 result is a valid ed25519 curve point. +createProgramAddress :: [BS.ByteString] -> SolanaPublicKey -> Either PdaError SolanaPublicKey +createProgramAddress seeds programId + | length seeds > 16 = Left TooManySeeds + | any ((> 32) . BS.length) seeds = Left SeedTooLong + | otherwise = + let digest :: Digest SHA256 + digest = hash (BS.concat seeds <> getSolanaPublicKeyRaw programId <> pdaMarker) + bytes = BS.pack (BA.unpack digest) + in if isOnCurve bytes + then Left InvalidSeeds + else Right (unsafeSolanaPublicKeyRaw (BS.unpack bytes)) + +-- | Find the first bump seed (255 downto 0) whose derived address is off +-- the curve, mirroring the Rust SDK's @Pubkey::find_program_address@. +findProgramAddress :: [BS.ByteString] -> SolanaPublicKey -> Maybe (SolanaPublicKey, Word8) +findProgramAddress seeds programId = go 255 + where + go :: Word8 -> Maybe (SolanaPublicKey, Word8) + go bump = + case createProgramAddress (seeds <> [BS.singleton bump]) programId of + Right addr -> Just (addr, bump) + Left InvalidSeeds + | bump == 0 -> Nothing + | otherwise -> go (bump - 1) + Left _ -> Nothing + +-- | A 32-byte string is "on curve" iff it decodes as a valid ed25519 point. +isOnCurve :: BS.ByteString -> Bool +isOnCurve bs = + case Edwards.pointDecode (BA.convert bs :: BA.Bytes) of + CryptoPassed _ -> True + CryptoFailed _ -> False diff --git a/src/Network/Solana/Core/Transaction.hs b/src/Network/Solana/Core/Transaction.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/Core/Transaction.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} + +-- | +-- Module : Network.Solana.Core.Transaction +-- Description : A Solana transaction: a compiled message plus its signatures. +module Network.Solana.Core.Transaction where + +import Data.Aeson.Types +import GHC.Generics +import Network.Solana.Core.Crypto (SolanaSignature) +import Network.Solana.Core.Message + +-- | A signed transaction as exchanged with RPC nodes: the compiled +-- message together with one signature per required signer. +data Transaction = Transaction + { -- | The compiled transaction message that was signed. + message :: CompiledMessage, + -- | Ed25519 signatures over the serialized message, one per required + -- signer, in the order of the message's signer account keys. + signatures :: [SolanaSignature] + } + deriving (Generic, Show, Eq) + deriving anyclass (ToJSON, FromJSON) diff --git a/src/Network/Solana/Core/VersionedMessage.hs b/src/Network/Solana/Core/VersionedMessage.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/Core/VersionedMessage.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Network.Solana.Core.VersionedMessage +-- Description : v0 message compilation (address lookup tables) and versioned-transaction signing. +module Network.Solana.Core.VersionedMessage + ( AddressLookupTableAccount (..), + MessageAddressTableLookup (..), + compileV0Message, + newV0TransactionIntent, + ) +where + +import Data.Binary +import Data.Binary.Put +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BL +import Data.List (elemIndex, partition) +import Data.Maybe (fromJust) +import GHC.Generics (Generic) +import Network.Solana.Core.Block (BlockHash) +import Network.Solana.Core.Compact +import Network.Solana.Core.Crypto (SolanaPrivateKey, SolanaPublicKey, dsign, toBase64String) +import Network.Solana.Core.Instruction +import Network.Solana.Core.Message + +------------------------------------------------------------------------------------------------ + +-- * AddressLookupTableAccount + +------------------------------------------------------------------------------------------------ + +-- | An address lookup table as loaded on-chain: its own address, and the +-- ordered list of addresses it stores. Passed to 'compileV0Message' as a +-- candidate source of accounts, so message account keys can be replaced by +-- a lookup index instead of being listed in full. +data AddressLookupTableAccount = AddressLookupTableAccount + { -- | The lookup table account's own address. + altKey :: SolanaPublicKey, + -- | The addresses stored in the table, in on-chain order (a key's + -- lookup index is its position in this list). + altAddresses :: [SolanaPublicKey] + } + deriving (Show, Eq, Generic) + +------------------------------------------------------------------------------------------------ + +-- * MessageAddressTableLookup + +------------------------------------------------------------------------------------------------ + +-- | A v0 message's reference to one address lookup table: the table's own +-- address, and the indexes within it to load as writable and read-only +-- accounts respectively. +data MessageAddressTableLookup = MessageAddressTableLookup + { -- | The lookup table account's own address. + mtlAccountKey :: SolanaPublicKey, + -- | Indexes of writable accounts to load from the table. + mtlWritableIndexes :: [Word8], + -- | Indexes of read-only accounts to load from the table. + mtlReadonlyIndexes :: [Word8] + } + deriving (Show, Eq, Generic) + +instance Binary MessageAddressTableLookup where + put :: MessageAddressTableLookup -> Put + put MessageAddressTableLookup {..} = do + put mtlAccountKey + put (mkCompact mtlWritableIndexes) + put (mkCompact mtlReadonlyIndexes) + get :: Get MessageAddressTableLookup + get = + MessageAddressTableLookup + <$> get + <*> (unCompact <$> get) + <*> (unCompact <$> get) + +------------------------------------------------------------------------------------------------ + +-- * Compile v0 message + +------------------------------------------------------------------------------------------------ + +-- | Compile a v0 message (mirrors the Rust SDK's @v0::Message::try_compile@): +-- build the legacy message (privilege union + canonical key ordering, via +-- 'mkNewMessage'), then move eligible writable-unsigned and +-- readonly-unsigned keys into the given lookup tables, in table order, with +-- the first table containing a key winning. Program ids and signers never +-- move to a lookup. Tables that end up with no keys loaded are omitted from +-- the serialized message. +-- +-- Fails with a 'CompileException' if a table has more than 256 addresses +-- and a key drained into it sits at position 256 or beyond — that position +-- cannot be represented in the byte-sized lookup index the wire format +-- requires, so it is rejected rather than silently truncated (wrapped) into +-- the wrong index, mirroring Rust's @AddressLookupTableIndexOverflow@. +-- +-- __A trap this module can't protect you from:__ an address only just added +-- to a lookup table by an @ExtendLookupTable@ instruction that landed in +-- slot @S@ only becomes eligible for lookup in a slot strictly greater than +-- @S@ -- on-chain, the table's @last_extended_slot@ is set to @S@, and its +-- active-address count stays at the length recorded in +-- @last_extended_slot_start_index@ (the table's length before the first +-- extension that landed in @S@ -- relevant if you batch several extends +-- into the same slot) until the current slot passes @S@. The invariant that +-- matters: whatever bank resolves the lookup (a preflight simulation, or +-- the bank that actually processes the transaction) must be at a slot +-- strictly greater than @S@, or the submission is rejected with +-- \"Transaction address table lookup uses an invalid index\" -- not a bug +-- in this function, but a real on-chain rule to wait out. Read @S@ back +-- with 'Network.Solana.NativePrograms.AddressLookupTable.decodeLookupTable' +-- (its 'Network.Solana.NativePrograms.AddressLookupTable.ltLastExtendedSlot' +-- field) if you need to check it explicitly; the convenience wrapper +-- 'Network.Solana.SolanaWeb3.getLookupTable' drops that field and returns +-- only 'AddressLookupTableAccount', so it can't be used for this check. +compileV0Message :: BlockHash -> [Instruction] -> [AddressLookupTableAccount] -> Either CompileException BS.ByteString +compileV0Message bh instructions tables = do + let legacy = mkNewMessage bh instructions + header = mHeader legacy + keys = mAccountKeys legacy + (rws, ros, rwus, rous) = splitAccountsByPurpose header keys + programIds = iProgramId <$> instructions + (rwusRemaining, rousRemaining, tableLoads) = drainTables programIds rwus rous tables + statics = rws <> ros <> rwusRemaining <> rousRemaining + newHeader = header {numReadonlyUnsignedAccounts = fromIntegral (length rousRemaining)} + resolutionKeys = + statics + <> concatMap tlWritableKeys tableLoads + <> concatMap tlReadonlyKeys tableLoads + byteIndexes <- mapM toByteIndexes tableLoads + let lookups = + [ MessageAddressTableLookup (altKey (tlTable tl)) writableIdx readonlyIdx + | (tl, (writableIdx, readonlyIdx)) <- zip tableLoads byteIndexes, + not (null writableIdx && null readonlyIdx) + ] + compiledInstructions <- mapM (compileInstruction resolutionKeys) (mInstructions legacy) + return . BL.toStrict . runPut $ do + putWord8 0x80 + put newHeader + put (mkCompact statics) + put (mRecentBlockhash legacy) + put (mkCompact compiledInstructions) + put (mkCompact lookups) + +-- | Sign a v0-compiled message with each signer's private key, and return +-- the Base64-encoded signed versioned transaction (compact signature array +-- followed by the message bytes). Mirrors 'Network.Solana.Core.Message.newTransactionIntent'. +-- The private keys passed here must be ordered to match the resulting account +-- order (fee payer first), otherwise the produced signatures will not correspond +-- to the right account keys. +-- +-- If any given table was extended very recently, see the note on +-- 'compileV0Message' about the resulting transaction's activation window: +-- whatever bank resolves the lookup must be at a slot strictly past the +-- table's last extension, regardless of the preflight commitment level used +-- to submit it (and regardless of preflight at all, if it is skipped). +newV0TransactionIntent :: [SolanaPrivateKey] -> [Instruction] -> [AddressLookupTableAccount] -> BlockHash -> Either CompileException String +newV0TransactionIntent signers instructions tables bh = do + msg <- compileV0Message bh instructions tables + let signatures = BL.toStrict . encode $ mkCompact $ flip dsign msg <$> signers + return $ toBase64String $ BS.append signatures msg + +------------------------------------------------------------------------------------------------ + +-- * Internal helpers + +------------------------------------------------------------------------------------------------ + +-- | The keys drained from the static writable-/readonly-unsigned sections +-- into one lookup table, alongside the resulting lookup positions. Positions +-- are kept as plain 'Int' (not yet 'Word8') since a table may have more than +-- 256 addresses; 'toByteIndexes' validates and narrows them. +data TableLoad = TableLoad + { tlTable :: AddressLookupTableAccount, + tlWritableKeys :: [SolanaPublicKey], + tlReadonlyKeys :: [SolanaPublicKey], + tlWritableIdx :: [Int], + tlReadonlyIdx :: [Int] + } + +-- | Drain eligible keys (present in a table's addresses, and not a program +-- id) from the writable-unsigned and readonly-unsigned pools into each +-- table in turn, preserving pool order within each table and leaving +-- already-drained keys unavailable to later tables. Returns the remaining +-- (undrained) pools and the per-table loads, in table order. +drainTables :: + [SolanaPublicKey] -> + [SolanaPublicKey] -> + [SolanaPublicKey] -> + [AddressLookupTableAccount] -> + ([SolanaPublicKey], [SolanaPublicKey], [TableLoad]) +drainTables _ rwus rous [] = (rwus, rous, []) +drainTables programIds rwus rous (table : rest) = + let addrs = altAddresses table + eligible k = k `notElem` programIds && k `elem` addrs + (wDrain, rwus') = partition eligible rwus + (rDrain, rous') = partition eligible rous + indexIn k = fromJust (elemIndex k addrs) + tableLoad = + TableLoad + { tlTable = table, + tlWritableKeys = wDrain, + tlReadonlyKeys = rDrain, + tlWritableIdx = indexIn <$> wDrain, + tlReadonlyIdx = indexIn <$> rDrain + } + (rwusFinal, rousFinal, restLoads) = drainTables programIds rwus' rous' rest + in (rwusFinal, rousFinal, tableLoad : restLoads) + +-- | Narrow one table's drained positions to the 'Word8' indexes the +-- serialized lookup format requires, failing if any position doesn't fit in +-- a byte. +toByteIndexes :: TableLoad -> Either CompileException ([Word8], [Word8]) +toByteIndexes tl + | all fitsInByte (tlWritableIdx tl <> tlReadonlyIdx tl) = + Right (fromIntegral <$> tlWritableIdx tl, fromIntegral <$> tlReadonlyIdx tl) + | otherwise = + Left + ( MissingIndex + ( "address table lookup index overflow: table " + <> show (altKey (tlTable tl)) + <> " has more than 256 addresses" + ) + ) + where + fitsInByte i = i <= fromIntegral (maxBound :: Word8) + +-- | Split a message's account keys into its four privilege sections +-- (writable-signed, readonly-signed, writable-unsigned, readonly-unsigned) +-- using the header's counts. Recomputed locally: 'Message'\'s equivalent +-- helper is not exported. +splitAccountsByPurpose :: + MessageHeader -> + [SolanaPublicKey] -> + ([SolanaPublicKey], [SolanaPublicKey], [SolanaPublicKey], [SolanaPublicKey]) +splitAccountsByPurpose (MessageHeader numRequiredSignatures' numReadonlySigned' numReadonlyUnsigned') keys = + let numRequiredSignatures = fromIntegral numRequiredSignatures' + numReadonlySigned = fromIntegral numReadonlySigned' + numReadonlyUnsigned = fromIntegral numReadonlyUnsigned' + (signed, unsigned) = splitAt numRequiredSignatures keys + (readAndWriteSigned, readOnlySigned) = splitAt (numRequiredSignatures - numReadonlySigned) signed + unsignedCount = length unsigned + (readAndWriteUnsigned, readOnlyUnsigned) = splitAt (unsignedCount - numReadonlyUnsigned) unsigned + in (readAndWriteSigned, readOnlySigned, readAndWriteUnsigned, readOnlyUnsigned) diff --git a/src/Network/Solana/Metaplex/TokenMetadata.hs b/src/Network/Solana/Metaplex/TokenMetadata.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/Metaplex/TokenMetadata.hs @@ -0,0 +1,377 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Client for the Metaplex Token Metadata program: attaches on-chain +-- metadata (name, symbol, URI, creators, royalties) to SPL Token mints and +-- registers "master edition" NFTs. Instruction data is Borsh-encoded (see +-- "Network.Solana.Core.Borsh"), unlike the native and SPL programs covered +-- elsewhere in this SDK, which use bincode or hand-rolled formats. +-- +-- Only three instructions are modeled: 'createMetadataAccountV3', +-- 'updateMetadataAccountV2' and 'createMasterEditionV3'. The rest of the +-- program (50+ instructions, programmable NFTs, delegates, Token-2022 +-- support) is out of scope. +module Network.Solana.Metaplex.TokenMetadata + ( tokenMetadataProgramId, + deriveMetadataAddress, + deriveMasterEditionAddress, + UseMethod (..), + Creator (..), + Collection (..), + Uses (..), + CollectionDetails (..), + DataV2 (..), + TokenMetadataInstruction (..), + createMetadataAccountV3, + updateMetadataAccountV2, + createMasterEditionV3, + Metadata (..), + decodeMetadata, + ) +where + +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BL +import Data.List (isPrefixOf) +import Data.Maybe (fromMaybe) +import GHC.Generics (Generic) +import Network.Solana.Core.Borsh +import Network.Solana.Core.Crypto +import Network.Solana.Core.Instruction +import Network.Solana.Core.Pda (findProgramAddress) +import Network.Solana.NativePrograms.SystemProgram qualified as SystemProgram +import Network.Solana.SplPrograms.Token qualified as Token +import Network.Solana.Sysvar qualified as Sysvar + +-- | Metaplex Token Metadata program address. +tokenMetadataProgramId :: SolanaPublicKey +tokenMetadataProgramId = "metaqbxxUerdq28cj1RbAWkYQm3ybzjb6a8bt518x1s" + +-- | Derive the metadata PDA for a mint: the PDA of +-- @["metadata", program id, mint]@ under the Token Metadata program. +deriveMetadataAddress :: SolanaPublicKey -> Maybe SolanaPublicKey +deriveMetadataAddress mint = + fst + <$> findProgramAddress + [ "metadata", + getSolanaPublicKeyRaw tokenMetadataProgramId, + getSolanaPublicKeyRaw mint + ] + tokenMetadataProgramId + +-- | Derive the master edition PDA for a mint: the PDA of +-- @["metadata", program id, mint, "edition"]@ under the Token Metadata program. +deriveMasterEditionAddress :: SolanaPublicKey -> Maybe SolanaPublicKey +deriveMasterEditionAddress mint = + fst + <$> findProgramAddress + [ "metadata", + getSolanaPublicKeyRaw tokenMetadataProgramId, + getSolanaPublicKeyRaw mint, + "edition" + ] + tokenMetadataProgramId + +-- | Which "uses" behavior an NFT carries (Borsh u8 enum index 0\/1\/2). +data UseMethod = Burn | Multiple | Single + deriving (Eq, Show, Enum, Bounded, Generic) + +putUseMethod :: UseMethod -> Put +putUseMethod = putWord8 . fromIntegral . fromEnum + +getUseMethod :: Get UseMethod +getUseMethod = do + b <- getWord8 + if b <= 2 + then pure (toEnum (fromIntegral b)) + else fail ("UseMethod: invalid value " <> show b) + +-- | A single NFT creator entry: address, whether they have verified their +-- inclusion, and their royalty share (0-100). +data Creator = Creator + { crAddress :: SolanaPublicKey, + crVerified :: Bool, + crShare :: Word8 + } + deriving (Eq, Show, Generic) + +instance Binary Creator where + put :: Creator -> Put + put (Creator addr verified share) = do + putByteString (getSolanaPublicKeyRaw addr) + putBorshBool verified + putWord8 share + get :: Get Creator + get = Creator <$> get <*> getBorshBool <*> getWord8 + +-- | The collection an NFT belongs to. +data Collection = Collection + { colVerified :: Bool, + colKey :: SolanaPublicKey + } + deriving (Eq, Show, Generic) + +instance Binary Collection where + put :: Collection -> Put + put (Collection verified key) = do + putBorshBool verified + putByteString (getSolanaPublicKeyRaw key) + get :: Get Collection + get = Collection <$> getBorshBool <*> get + +-- | Limited-use configuration for an NFT (e.g. burn-on-use tickets). +data Uses = Uses + { usesUseMethod :: UseMethod, + usesRemaining :: Word64, + usesTotal :: Word64 + } + deriving (Eq, Show, Generic) + +instance Binary Uses where + put :: Uses -> Put + put (Uses method usesRemaining' total) = do + putUseMethod method + putWord64le usesRemaining' + putWord64le total + get :: Get Uses + get = Uses <$> getUseMethod <*> getWord64le <*> getWord64le + +-- | Marks a Metadata account as a collection ("sized" collection, V1). Only +-- the V1 variant is modeled; decoding any other variant tag fails. +newtype CollectionDetails = CollectionDetailsV1 {cdSize :: Word64} + deriving (Eq, Show, Generic) + +instance Binary CollectionDetails where + put :: CollectionDetails -> Put + put (CollectionDetailsV1 size) = do + putWord8 0 + putWord64le size + get :: Get CollectionDetails + get = do + variant <- getWord8 + case variant of + 0 -> CollectionDetailsV1 <$> getWord64le + _ -> fail ("CollectionDetails: unsupported variant " <> show variant) + +-- | The mutable on-chain fields of a Metadata account. +data DataV2 = DataV2 + { dName :: String, + dSymbol :: String, + dUri :: String, + dSellerFeeBasisPoints :: Word16, + dCreators :: Maybe [Creator], + dCollection :: Maybe Collection, + dUses :: Maybe Uses + } + deriving (Eq, Show, Generic) + +instance Binary DataV2 where + put :: DataV2 -> Put + put (DataV2 name symbol uri fee creators collection uses) = do + putBorshString name + putBorshString symbol + putBorshString uri + putWord16le fee + putBorshOption (putBorshVec put) creators + putBorshOption put collection + putBorshOption put uses + get :: Get DataV2 + get = + DataV2 + <$> getBorshString + <*> getBorshString + <*> getBorshString + <*> getWord16le + <*> getBorshOption (getBorshVec get) + <*> getBorshOption get + <*> getBorshOption get + +-- | On-chain state of a Metadata account (the @Metadata@ struct from +-- @mpl-token-metadata@). The head fields are always present; the tail +-- (edition nonce, token standard, collection, uses) was added across +-- several program upgrades, so older accounts simply end early. +data Metadata = Metadata + { mdKey :: Word8, + mdUpdateAuthority :: SolanaPublicKey, + mdMint :: SolanaPublicKey, + mdName :: String, + mdSymbol :: String, + mdUri :: String, + mdSellerFeeBasisPoints :: Word16, + mdCreators :: Maybe [Creator], + mdPrimarySaleHappened :: Bool, + mdIsMutable :: Bool, + mdEditionNonce :: Maybe Word8, + mdTokenStandard :: Maybe Word8, + mdCollection :: Maybe Collection, + mdUses :: Maybe Uses + } + deriving (Eq, Show) + +-- | Strips trailing NUL padding from a Borsh string field. @name@, @symbol@ +-- and @uri@ are stored in fixed-size, NUL-padded buffers on-chain. +trimNuls :: String -> String +trimNuls = reverse . dropWhile (== '\0') . reverse + +-- | Decodes a Metadata account's data: a Borsh-encoded @key@, two pubkeys, +-- the three NUL-padded name\/symbol\/uri strings, royalty fee, creators, +-- and the @primarySaleHappened@\/@isMutable@ flags, followed by a tolerant +-- tail of @editionNonce@, @tokenStandard@, @collection@ and @uses@: each is +-- read only if bytes remain, and any bytes left over after @uses@ (account +-- padding) are ignored. Fails if the key byte is not 4 (MetadataV1). +decodeMetadata :: BS.ByteString -> Either String Metadata +decodeMetadata bs = case runGetOrFail getMetadata (BL.fromStrict bs) of + Left (_, _, err) -> Left (prefixError err) + Right (_, _, m) -> Right m + where + prefixError err = + if "Metadata:" `isPrefixOf` err then err else "Metadata: " <> err + getMetadata = do + k <- getWord8 + if k /= 4 + then fail ("Metadata: unexpected account key " <> show k <> " (expected 4)") + else Metadata k + <$> get + <*> get + <*> (trimNuls <$> getBorshString) + <*> (trimNuls <$> getBorshString) + <*> (trimNuls <$> getBorshString) + <*> getWord16le + <*> getBorshOption (getBorshVec get) + <*> getBorshBool + <*> getBorshBool + <*> getTolerantOption getWord8 + <*> getTolerantOption getWord8 + <*> getTolerantOption get + <*> getTolerantOption get + getTolerantOption getVal = do + e <- isEmpty + if e then pure Nothing else getBorshOption getVal + +-- | Token Metadata instructions covered by this client (Borsh u8 +-- discriminants, arbitrated by the @mpl-token-metadata@ crate's fixtures). +data TokenMetadataInstruction + = -- | Create a Metadata account (v3) for a mint. Discriminant 33. + CreateMetadataAccountV3 + { cmaData :: DataV2, + cmaIsMutable :: Bool, + cmaCollectionDetails :: Maybe CollectionDetails + } + | -- | Update an existing Metadata account (v2). Discriminant 15. + UpdateMetadataAccountV2 + { umaData :: Maybe DataV2, + umaUpdateAuthority :: Maybe SolanaPublicKey, + umaPrimarySaleHappened :: Maybe Bool, + umaIsMutable :: Maybe Bool + } + | -- | Register a Metadata account as a Master Edition (v3). Discriminant 17. + CreateMasterEditionV3 + { cmeMaxSupply :: Maybe Word64 + } + deriving (Eq, Show, Generic) + +instance Binary TokenMetadataInstruction where + put :: TokenMetadataInstruction -> Put + put (CreateMetadataAccountV3 dataV2 isMutable collectionDetails) = do + putWord8 33 + put dataV2 + putBorshBool isMutable + putBorshOption put collectionDetails + put (UpdateMetadataAccountV2 dataV2 updateAuthority primarySaleHappened isMutable) = do + putWord8 15 + putBorshOption put dataV2 + putBorshOption (putByteString . getSolanaPublicKeyRaw) updateAuthority + putBorshOption putBorshBool primarySaleHappened + putBorshOption putBorshBool isMutable + put (CreateMasterEditionV3 maxSupply) = do + putWord8 17 + putBorshOption putWord64le maxSupply + + get :: Get TokenMetadataInstruction + get = do + disc <- getWord8 + case disc of + 33 -> CreateMetadataAccountV3 <$> get <*> getBorshBool <*> getBorshOption get + 15 -> + UpdateMetadataAccountV2 + <$> getBorshOption get + <*> getBorshOption get + <*> getBorshOption getBorshBool + <*> getBorshOption getBorshBool + 17 -> CreateMasterEditionV3 <$> getBorshOption getWord64le + _ -> fail ("TokenMetadataInstruction: unknown discriminant " <> show disc) + +-- | Create a new Metadata account (v3) for a mint. +-- Fails with 'error' if PDA derivation fails (established precedent, see +-- "Network.Solana.SplPrograms.AssociatedTokenAccount"). +-- # Account references (no rent account — matches the reference crate, +-- which omits the optional rent account entirely when unset) +-- 0. `[WRITE]` Metadata account (derived) +-- 1. `[]` Mint account +-- 2. `[SIGNER]` Mint authority +-- 3. `[WRITE, SIGNER]` Payer +-- 4. `[]` Update authority (signer iff @updateAuthorityIsSigner@) +-- 5. `[]` System program +createMetadataAccountV3 :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> Bool -> DataV2 -> Bool -> Maybe CollectionDetails -> Instruction +createMetadataAccountV3 mint mintAuthority payer updateAuthority updateAuthorityIsSigner dataV2 isMutable collectionDetails = + mkInstruction + tokenMetadataProgramId + [ AccountMeta {accountPubKey = metadata, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = mint, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = mintAuthority, isSigner = True, isWritable = False}, + AccountMeta {accountPubKey = payer, isSigner = True, isWritable = True}, + AccountMeta {accountPubKey = updateAuthority, isSigner = updateAuthorityIsSigner, isWritable = False}, + AccountMeta {accountPubKey = SystemProgram.systemProgramId, isSigner = False, isWritable = False} + ] + (CreateMetadataAccountV3 dataV2 isMutable collectionDetails) + where + metadata = fromMaybe (error "createMetadataAccountV3: metadata PDA derivation failed") (deriveMetadataAddress mint) + +-- | Update an existing Metadata account (v2). +-- # Account references +-- 0. `[WRITE]` Metadata account (derived) +-- 1. `[SIGNER]` Update authority +updateMetadataAccountV2 :: SolanaPublicKey -> SolanaPublicKey -> Maybe DataV2 -> Maybe SolanaPublicKey -> Maybe Bool -> Maybe Bool -> Instruction +updateMetadataAccountV2 mint updateAuthority dataV2 newUpdateAuthority primarySaleHappened isMutable = + mkInstruction + tokenMetadataProgramId + [ AccountMeta {accountPubKey = metadata, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = updateAuthority, isSigner = True, isWritable = False} + ] + (UpdateMetadataAccountV2 dataV2 newUpdateAuthority primarySaleHappened isMutable) + where + metadata = fromMaybe (error "updateMetadataAccountV2: metadata PDA derivation failed") (deriveMetadataAddress mint) + +-- | Register a Metadata account as a Master Edition (v3), fixing the +-- maximum number of print editions (or making it unlimited when 'Nothing'). +-- Fails with 'error' if PDA derivation fails (see 'createMetadataAccountV3'). +-- # Account references +-- 0. `[WRITE]` Master Edition account (derived) +-- 1. `[WRITE]` Mint account +-- 2. `[SIGNER]` Update authority +-- 3. `[SIGNER]` Mint authority +-- 4. `[WRITE, SIGNER]` Payer +-- 5. `[]` Metadata account (derived) +-- 6. `[]` Token program +-- 7. `[]` System program +-- 8. `[]` Rent sysvar +createMasterEditionV3 :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> Maybe Word64 -> Instruction +createMasterEditionV3 mint updateAuthority mintAuthority payer maxSupply = + mkInstruction + tokenMetadataProgramId + [ AccountMeta {accountPubKey = edition, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = mint, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = updateAuthority, isSigner = True, isWritable = False}, + AccountMeta {accountPubKey = mintAuthority, isSigner = True, isWritable = False}, + AccountMeta {accountPubKey = payer, isSigner = True, isWritable = True}, + AccountMeta {accountPubKey = metadata, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = Token.tokenProgramId, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = SystemProgram.systemProgramId, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = Sysvar.rent, isSigner = False, isWritable = False} + ] + (CreateMasterEditionV3 maxSupply) + where + edition = fromMaybe (error "createMasterEditionV3: master edition PDA derivation failed") (deriveMasterEditionAddress mint) + metadata = fromMaybe (error "createMasterEditionV3: metadata PDA derivation failed") (deriveMetadataAddress mint) diff --git a/src/Network/Solana/NativePrograms/AddressLookupTable.hs b/src/Network/Solana/NativePrograms/AddressLookupTable.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/NativePrograms/AddressLookupTable.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Client for the Address Lookup Table program. Instruction data is +-- bincode-encoded (u32 little-endian discriminant), like the System +-- Program; the @ExtendLookupTable@ variant's address vector is bincode's +-- @Vec\@ encoding (u64 little-endian count followed by the raw +-- 32-byte keys). +module Network.Solana.NativePrograms.AddressLookupTable where + +import Control.Monad (replicateM) +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BL +import Data.Maybe (fromMaybe) +import GHC.Generics (Generic) +import Network.Solana.Core.Crypto +import Network.Solana.Core.Instruction +import Network.Solana.Core.Pda (findProgramAddress) +import Network.Solana.Core.VersionedMessage qualified as VM +import Network.Solana.NativePrograms.SystemProgram qualified as SP + +-- | Address Lookup Table program address. +addressLookupTableProgramId :: SolanaPublicKey +addressLookupTableProgramId = "AddressLookupTab1e1111111111111111111111111" + +-- | Address Lookup Table program instructions. +data AddressLookupTableInstruction + = CreateLookupTable {recentSlot :: Word64, bumpSeed :: Word8} + | FreezeLookupTable + | ExtendLookupTable {newAddresses :: [SolanaPublicKey]} + | DeactivateLookupTable + | CloseLookupTable + deriving (Eq, Show, Generic) + +-- bincode encodes a Rust Vec as a u64 little-endian count followed +-- by the raw 32-byte keys. +putBincodeVec :: [SolanaPublicKey] -> Put +putBincodeVec pks = do + putWord64le (fromIntegral (length pks)) + mapM_ (putByteString . getSolanaPublicKeyRaw) pks + +-- | bincode decodes a Rust Vec as a u64 little-endian count +-- followed by that many raw 32-byte keys. +getBincodeVec :: Get [SolanaPublicKey] +getBincodeVec = do + count <- getWord64le + if count > fromIntegral (maxBound :: Int) + then fail "getBincodeVec: count exceeds Int range" + else replicateM (fromIntegral count) get + +instance Binary AddressLookupTableInstruction where + put :: AddressLookupTableInstruction -> Put + put (CreateLookupTable slot bump) = do + putWord32le 0 + putWord64le slot + putWord8 bump + put FreezeLookupTable = putWord32le 1 + put (ExtendLookupTable addrs) = do + putWord32le 2 + putBincodeVec addrs + put DeactivateLookupTable = putWord32le 3 + put CloseLookupTable = putWord32le 4 + + get :: Get AddressLookupTableInstruction + get = do + disc <- getWord32le + case disc of + 0 -> CreateLookupTable <$> getWord64le <*> getWord8 + 1 -> pure FreezeLookupTable + 2 -> ExtendLookupTable <$> getBincodeVec + 3 -> pure DeactivateLookupTable + 4 -> pure CloseLookupTable + _ -> fail ("AddressLookupTableInstruction: unknown discriminant " <> show disc) + +-- | An address lookup table account's on-chain state: the fixed-size +-- @LookupTableMeta@ fields followed by the raw stored addresses. +data LookupTableState = LookupTableState + { ltDeactivationSlot :: Word64, + ltLastExtendedSlot :: Word64, + ltLastExtendedSlotStartIndex :: Word8, + ltAuthority :: Maybe SolanaPublicKey, + ltAddresses :: [SolanaPublicKey] + } + deriving (Eq, Show) + +-- | Decodes an address lookup table account's data. The first 56 bytes are +-- the fixed @LookupTableMeta@ region (u32 discriminant, two u64 slots, a u8 +-- start index, a bincode @Option\@ authority, and trailing padding +-- up to the 56-byte boundary); the remainder is the raw table of 32-byte +-- addresses. +decodeLookupTable :: BS.ByteString -> Either String LookupTableState +decodeLookupTable bs + | BS.length bs < 56 = + Left ("LookupTableState: expected at least 56 bytes, got " <> show (BS.length bs)) + | otherwise = do + (deactivationSlot, lastExtendedSlot, startIndex, authority) <- parseMeta (BS.take 56 bs) + addresses <- parseAddresses (BS.drop 56 bs) + Right (LookupTableState deactivationSlot lastExtendedSlot startIndex authority addresses) + where + parseMeta chunk = case runGetOrFail getMeta (BL.fromStrict chunk) of + Left (_, _, err) -> Left err + Right (_, _, v) -> Right v + getMeta = do + disc <- getWord32le + case disc of + 0 -> fail "LookupTableState: uninitialized lookup table" + 1 -> + (,,,) + <$> getWord64le + <*> getWord64le + <*> getWord8 + <*> getOptionalAuthority + _ -> fail ("LookupTableState: unknown discriminant " <> show disc) + getOptionalAuthority = do + tag <- getWord8 + case tag of + 0 -> pure Nothing + 1 -> Just <$> get + _ -> fail ("LookupTableState: invalid authority option tag " <> show tag) + parseAddresses addrBytes + | remainder /= 0 = + Left ("LookupTableState: addresses length " <> show (BS.length addrBytes) <> " is not a multiple of 32") + | otherwise = case runGetOrFail (replicateM count get) (BL.fromStrict addrBytes) of + Left (_, _, err) -> Left err + Right (_, _, addrs) -> Right addrs + where + (count, remainder) = BS.length addrBytes `divMod` 32 + +-- | Builds the 'VM.AddressLookupTableAccount' 'Network.Solana.Core.VersionedMessage.compileV0Message' expects from +-- the table's own address and its decoded on-chain state. +lookupTableToAccount :: SolanaPublicKey -> LookupTableState -> VM.AddressLookupTableAccount +lookupTableToAccount key state = VM.AddressLookupTableAccount key (ltAddresses state) + +-- | Derives the address of a lookup table for a given authority and recent +-- slot: the PDA of @[authority, recentSlot as 8 little-endian bytes]@ under +-- the Address Lookup Table program. +deriveLookupTableAddress :: SolanaPublicKey -> Word64 -> Maybe (SolanaPublicKey, Word8) +deriveLookupTableAddress authority slot = + findProgramAddress + [ getSolanaPublicKeyRaw authority, + BL.toStrict (runPut (putWord64le slot)) + ] + addressLookupTableProgramId + +-- | Creates instruction to "Create a lookup table" and returns it together +-- with the table's derived address. +-- Receives the authority (not required to sign), the payer (which must +-- sign) and the recent slot used to derive the table's address. +-- Calls 'error' if the lookup-table address cannot be derived (practically +-- unreachable: requires every bump candidate to land on-curve). +-- # Account references +-- 0. `[WRITE]` Uninitialized lookup table account +-- 1. `[]` Authority +-- 2. `[WRITE, SIGNER]` Payer account +-- 3. `[]` System program +createLookupTable :: SolanaPublicKey -> SolanaPublicKey -> Word64 -> (Instruction, SolanaPublicKey) +createLookupTable authority payer slot = + let (table, bump) = + fromMaybe + (error "deriveLookupTableAddress: derivation failed") + (deriveLookupTableAddress authority slot) + ix = + mkInstruction + addressLookupTableProgramId + [ AccountMeta {accountPubKey = table, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = authority, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = payer, isSigner = True, isWritable = True}, + AccountMeta {accountPubKey = SP.systemProgramId, isSigner = False, isWritable = False} + ] + (CreateLookupTable slot bump) + in (ix, table) + +-- | Creates instruction to "Freeze a lookup table, making it immutable" +-- Receives the lookup table account and its authority (which must sign). +-- # Account references +-- 0. `[WRITE]` Lookup table account +-- 1. `[SIGNER]` Authority +freezeLookupTable :: SolanaPublicKey -> SolanaPublicKey -> Instruction +freezeLookupTable table authority = + mkInstruction + addressLookupTableProgramId + [ AccountMeta {accountPubKey = table, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = authority, isSigner = True, isWritable = False} + ] + FreezeLookupTable + +-- | Creates instruction to "Extend a lookup table with new addresses" +-- Receives the lookup table account, its authority (which must sign), an +-- optional payer to fund the extension (the system program is always +-- included alongside it) and the addresses to append. +-- # Account references +-- 0. `[WRITE]` Lookup table account +-- 1. `[SIGNER]` Authority +-- 2. `[WRITE, SIGNER]` (optional) Payer account +-- 3. `[]` (optional) System program +extendLookupTable :: SolanaPublicKey -> SolanaPublicKey -> Maybe SolanaPublicKey -> [SolanaPublicKey] -> Instruction +extendLookupTable table authority mPayer addrs = + mkInstruction + addressLookupTableProgramId + ( [ AccountMeta {accountPubKey = table, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = authority, isSigner = True, isWritable = False} + ] + ++ maybe + [] + ( \payer -> + [ AccountMeta {accountPubKey = payer, isSigner = True, isWritable = True}, + AccountMeta {accountPubKey = SP.systemProgramId, isSigner = False, isWritable = False} + ] + ) + mPayer + ) + (ExtendLookupTable addrs) + +-- | Creates instruction to "Deactivate a lookup table, making it unusable +-- and eligible for closure once it is no longer referenced by any +-- transaction" +-- Receives the lookup table account and its authority (which must sign). +-- # Account references +-- 0. `[WRITE]` Lookup table account +-- 1. `[SIGNER]` Authority +deactivateLookupTable :: SolanaPublicKey -> SolanaPublicKey -> Instruction +deactivateLookupTable table authority = + mkInstruction + addressLookupTableProgramId + [ AccountMeta {accountPubKey = table, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = authority, isSigner = True, isWritable = False} + ] + DeactivateLookupTable + +-- | Creates instruction to "Close a deactivated lookup table, reclaiming +-- its lamports" +-- Receives the lookup table account, its authority (which must sign) and +-- the recipient of the reclaimed lamports. +-- # Account references +-- 0. `[WRITE]` Lookup table account +-- 1. `[SIGNER]` Authority +-- 2. `[WRITE]` Recipient account +closeLookupTable :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> Instruction +closeLookupTable table authority recipient = + mkInstruction + addressLookupTableProgramId + [ AccountMeta {accountPubKey = table, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = authority, isSigner = True, isWritable = False}, + AccountMeta {accountPubKey = recipient, isSigner = False, isWritable = True} + ] + CloseLookupTable diff --git a/src/Network/Solana/NativePrograms/BpfLoaderUpgradeable.hs b/src/Network/Solana/NativePrograms/BpfLoaderUpgradeable.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/NativePrograms/BpfLoaderUpgradeable.hs @@ -0,0 +1,263 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Client for the Upgradeable BPF Loader program (loader-v3). Instruction +-- data is bincode-encoded (u32 little-endian discriminant), like the System +-- Program; the @Write@ variant's byte vector is bincode's @Vec\@ encoding +-- (u64 little-endian length followed by the raw bytes). +-- +-- Rust's composite helpers (@create_buffer@, @deploy_with_max_program_len@) +-- are deliberately not mirrored: compose them from the System Program client +-- (createAccount) plus 'initializeBuffer' / 'deployWithMaxDataLen'. +module Network.Solana.NativePrograms.BpfLoaderUpgradeable where + +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import Data.ByteString qualified as BS +import GHC.Generics (Generic) +import Network.Solana.Core.Crypto +import Network.Solana.Core.Instruction +import Network.Solana.Core.Pda (findProgramAddress) +import Network.Solana.NativePrograms.SystemProgram qualified as SP +import Network.Solana.Sysvar qualified as Sysvar + +-- | Upgradeable BPF loader program address. +-- +-- Named after the Rust SDK's @bpf_loader_upgradeable@ module rather than the +-- @...ProgramId@ convention used elsewhere in this SDK; kept intentionally +-- for symmetry with upstream. +bpfLoaderUpgradeableId :: SolanaPublicKey +bpfLoaderUpgradeableId = "BPFLoaderUpgradeab1e11111111111111111111111" + +-- | Upgradeable BPF loader program instructions. +data UpgradeableLoaderInstruction + = InitializeBuffer + | Write {wOffset :: Word32, wBytes :: BS.ByteString} + | DeployWithMaxDataLen {dMaxDataLen :: Word64} + | Upgrade + | SetAuthority + | Close + | ExtendProgram {eAdditionalBytes :: Word32} + | SetAuthorityChecked + deriving (Eq, Show, Generic) + +-- bincode encodes a Rust Vec as a u64 little-endian byte length +-- followed by the raw bytes. +putBincodeBytes :: BS.ByteString -> Put +putBincodeBytes bs = do + putWord64le (fromIntegral (BS.length bs)) + putByteString bs + +-- | bincode decodes a Rust Vec as a u64 little-endian byte length +-- followed by that many raw bytes. +getBincodeBytes :: Get BS.ByteString +getBincodeBytes = do + len <- getWord64le + if len > fromIntegral (maxBound :: Int) + then fail "getBincodeBytes: length exceeds Int range" + else getByteString (fromIntegral len) + +instance Binary UpgradeableLoaderInstruction where + put :: UpgradeableLoaderInstruction -> Put + put InitializeBuffer = putWord32le 0 + put (Write offset bytes) = do + putWord32le 1 + putWord32le offset + putBincodeBytes bytes + put (DeployWithMaxDataLen maxDataLen) = do + putWord32le 2 + putWord64le maxDataLen + put Upgrade = putWord32le 3 + put SetAuthority = putWord32le 4 + put Close = putWord32le 5 + put (ExtendProgram additionalBytes) = do + putWord32le 6 + putWord32le additionalBytes + put SetAuthorityChecked = putWord32le 7 + + get :: Get UpgradeableLoaderInstruction + get = do + disc <- getWord32le + case disc of + 0 -> pure InitializeBuffer + 1 -> Write <$> getWord32le <*> getBincodeBytes + 2 -> DeployWithMaxDataLen <$> getWord64le + 3 -> pure Upgrade + 4 -> pure SetAuthority + 5 -> pure Close + 6 -> ExtendProgram <$> getWord32le + 7 -> pure SetAuthorityChecked + _ -> fail ("UpgradeableLoaderInstruction: unknown discriminant " <> show disc) + +-- | Derives the ProgramData account address for a given program: the PDA of +-- @[program]@ under the upgradeable BPF loader. +programDataAddress :: SolanaPublicKey -> Maybe SolanaPublicKey +programDataAddress prog = fst <$> findProgramAddress [getSolanaPublicKeyRaw prog] bpfLoaderUpgradeableId + +-- | Creates instruction to "Initialize a Buffer account" +-- Receives the uninitialized buffer account and its authority. +-- # Account references +-- 0. `[WRITE]` Source account to initialize +-- 1. `[]` Buffer authority +initializeBuffer :: SolanaPublicKey -> SolanaPublicKey -> Instruction +initializeBuffer buffer authority = + mkInstruction + bpfLoaderUpgradeableId + [ AccountMeta {accountPubKey = buffer, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = authority, isSigner = False, isWritable = False} + ] + InitializeBuffer + +-- | Creates instruction to "Write program data into a Buffer account" +-- Receives the buffer account, its authority (which must sign), the byte +-- offset and the bytes to write. +-- # Account references +-- 0. `[WRITE]` Buffer account to write to +-- 1. `[SIGNER]` Buffer authority +write :: SolanaPublicKey -> SolanaPublicKey -> Word32 -> BS.ByteString -> Instruction +write buffer authority offset bytes = + mkInstruction + bpfLoaderUpgradeableId + [ AccountMeta {accountPubKey = buffer, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = authority, isSigner = True, isWritable = False} + ] + (Write offset bytes) + +-- | Creates instruction to "Deploy an executable program" +-- Receives the payer, the uninitialized ProgramData account, the +-- uninitialized Program account, the Buffer account holding the deployed +-- program data, the authority (which must sign) and the maximum length in +-- bytes the program can be upgraded to. +-- # Account references +-- 0. `[WRITE, SIGNER]` Payer account +-- 1. `[WRITE]` ProgramData account +-- 2. `[WRITE]` Program account +-- 3. `[WRITE]` Buffer account +-- 4. `[]` Rent sysvar +-- 5. `[]` Clock sysvar +-- 6. `[]` System program +-- 7. `[SIGNER]` Authority +deployWithMaxDataLen :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> Word64 -> Instruction +deployWithMaxDataLen payer programdata program buffer authority maxDataLen = + mkInstruction + bpfLoaderUpgradeableId + [ AccountMeta {accountPubKey = payer, isSigner = True, isWritable = True}, + AccountMeta {accountPubKey = programdata, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = program, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = buffer, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = Sysvar.rent, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = Sysvar.clock, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = SP.systemProgramId, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = authority, isSigner = True, isWritable = False} + ] + (DeployWithMaxDataLen maxDataLen) + +-- | Creates instruction to "Upgrade a program" +-- Receives the ProgramData account, the Program account, the Buffer account +-- holding the new program data, the spill account (which receives excess +-- lamports) and the authority (which must sign). +-- # Account references +-- 0. `[WRITE]` ProgramData account +-- 1. `[WRITE]` Program account +-- 2. `[WRITE]` Buffer account +-- 3. `[WRITE]` Spill account +-- 4. `[]` Rent sysvar +-- 5. `[]` Clock sysvar +-- 6. `[SIGNER]` Authority +upgrade :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> Instruction +upgrade programdata program buffer spill authority = + mkInstruction + bpfLoaderUpgradeableId + [ AccountMeta {accountPubKey = programdata, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = program, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = buffer, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = spill, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = Sysvar.rent, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = Sysvar.clock, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = authority, isSigner = True, isWritable = False} + ] + Upgrade + +-- | Creates instruction to "Set a new authority" +-- Receives the account whose authority is being changed, the current +-- authority (which must sign) and the new authority. +-- # Account references +-- 0. `[WRITE]` Buffer or ProgramData account +-- 1. `[SIGNER]` Current authority +-- 2. `[]` New authority +setAuthority :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> Instruction +setAuthority owned currentAuthority newAuthority = + mkInstruction + bpfLoaderUpgradeableId + [ AccountMeta {accountPubKey = owned, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = currentAuthority, isSigner = True, isWritable = False}, + AccountMeta {accountPubKey = newAuthority, isSigner = False, isWritable = False} + ] + SetAuthority + +-- | Creates instruction to "Set a new authority", checking that the new +-- authority signs (a safer version of 'setAuthority'). +-- Receives the account whose authority is being changed, the current +-- authority (which must sign) and the new authority (which must sign). +-- # Account references +-- 0. `[WRITE]` Buffer or ProgramData account +-- 1. `[SIGNER]` Current authority +-- 2. `[SIGNER]` New authority +setAuthorityChecked :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> Instruction +setAuthorityChecked owned currentAuthority newAuthority = + mkInstruction + bpfLoaderUpgradeableId + [ AccountMeta {accountPubKey = owned, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = currentAuthority, isSigner = True, isWritable = False}, + AccountMeta {accountPubKey = newAuthority, isSigner = True, isWritable = False} + ] + SetAuthorityChecked + +-- | Creates instruction to "Close an account" +-- Receives the account to close, the recipient of its lamports, the +-- authority (which must sign) and, when closing a ProgramData account, the +-- associated Program account. +-- # Account references +-- 0. `[WRITE]` Account to close +-- 1. `[WRITE]` Recipient account +-- 2. `[SIGNER]` Authority +-- 3. `[WRITE]` (optional) Associated Program account, if closing a ProgramData account +closeAccount :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> Maybe SolanaPublicKey -> Instruction +closeAccount account recipient authority mProgram = + mkInstruction + bpfLoaderUpgradeableId + ( [ AccountMeta {accountPubKey = account, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = recipient, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = authority, isSigner = True, isWritable = False} + ] + ++ maybe [] (\p -> [AccountMeta {accountPubKey = p, isSigner = False, isWritable = True}]) mProgram + ) + Close + +-- | Creates instruction to "Extend a program's ProgramData account by the +-- given number of bytes" +-- Receives the ProgramData account, the Program account, an optional payer +-- to fund the extension (the system program is always included alongside +-- it), and the number of additional bytes. +-- # Account references +-- 0. `[WRITE]` ProgramData account +-- 1. `[WRITE]` Program account +-- 2. `[]` (optional) System program +-- 3. `[WRITE, SIGNER]` (optional) Payer account +extendProgram :: SolanaPublicKey -> SolanaPublicKey -> Maybe SolanaPublicKey -> Word32 -> Instruction +extendProgram programdata program mPayer additionalBytes = + mkInstruction + bpfLoaderUpgradeableId + ( [ AccountMeta {accountPubKey = programdata, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = program, isSigner = False, isWritable = True} + ] + ++ maybe + [] + ( \payer -> + [ AccountMeta {accountPubKey = SP.systemProgramId, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = payer, isSigner = True, isWritable = True} + ] + ) + mPayer + ) + (ExtendProgram additionalBytes) diff --git a/src/Network/Solana/NativePrograms/ComputeBudget.hs b/src/Network/Solana/NativePrograms/ComputeBudget.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/NativePrograms/ComputeBudget.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.Solana.NativePrograms.ComputeBudget where + +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import GHC.Generics (Generic) +import Network.Solana.Core.Crypto (SolanaPublicKey) +import Network.Solana.Core.Instruction + +-- | Compute Budget program address. This program contains instructions to +-- set transaction-wide compute limits, heap size and a compute unit price +-- ("priority fee") for transaction prioritization. +computeBudgetProgramId :: SolanaPublicKey +computeBudgetProgramId = "ComputeBudget111111111111111111111111111111" + +-- | Compute Budget instructions, serialized in the Rust SDK's borsh layout: +-- a single-byte discriminant followed by the little-endian field. +-- The deprecated variant 0 is intentionally not modeled. +data ComputeBudgetInstruction + = -- | Request a specific transaction-wide program heap region size in bytes + -- (must be a multiple of 1024) + RequestHeapFrame Word32 + | -- | Set a specific compute unit limit that the transaction is allowed to consume + SetComputeUnitLimit Word32 + | -- | Set a compute unit price in micro-lamports to pay a higher transaction + -- fee for higher transaction prioritization + SetComputeUnitPrice Word64 + | -- | Set a specific transaction-wide account data size limit, in bytes, allowed to load + SetLoadedAccountsDataSizeLimit Word32 + deriving (Eq, Show, Generic) + +instance Binary ComputeBudgetInstruction where + put :: ComputeBudgetInstruction -> Put + put (RequestHeapFrame bytes) = do + putWord8 1 + putWord32le bytes + put (SetComputeUnitLimit units) = do + putWord8 2 + putWord32le units + put (SetComputeUnitPrice microLamports) = do + putWord8 3 + putWord64le microLamports + put (SetLoadedAccountsDataSizeLimit bytes) = do + putWord8 4 + putWord32le bytes + + get :: Get ComputeBudgetInstruction + get = do + disc <- getWord8 + case disc of + 1 -> RequestHeapFrame <$> getWord32le + 2 -> SetComputeUnitLimit <$> getWord32le + 3 -> SetComputeUnitPrice <$> getWord64le + 4 -> SetLoadedAccountsDataSizeLimit <$> getWord32le + _ -> fail ("ComputeBudgetInstruction: unknown discriminant " <> show disc) + +-- | Creates instruction to "Request a transaction-wide program heap region size in bytes". +-- Compute Budget instructions take no accounts. +requestHeapFrame :: Word32 -> Instruction +requestHeapFrame bytes = mkInstruction computeBudgetProgramId [] (RequestHeapFrame bytes) + +-- | Creates instruction to "Set the transaction's compute unit limit". +-- Compute Budget instructions take no accounts. +setComputeUnitLimit :: Word32 -> Instruction +setComputeUnitLimit units = mkInstruction computeBudgetProgramId [] (SetComputeUnitLimit units) + +-- | Creates instruction to "Set the compute unit price in micro-lamports" (priority fee). +-- Compute Budget instructions take no accounts. +setComputeUnitPrice :: Word64 -> Instruction +setComputeUnitPrice microLamports = mkInstruction computeBudgetProgramId [] (SetComputeUnitPrice microLamports) + +-- | Creates instruction to "Set the transaction-wide loaded account data size limit in bytes". +-- Compute Budget instructions take no accounts. +setLoadedAccountsDataSizeLimit :: Word32 -> Instruction +setLoadedAccountsDataSizeLimit bytes = mkInstruction computeBudgetProgramId [] (SetLoadedAccountsDataSizeLimit bytes) diff --git a/src/Network/Solana/NativePrograms/Secp256k1.hs b/src/Network/Solana/NativePrograms/Secp256k1.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/NativePrograms/Secp256k1.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Client for the Secp256k1 native precompile program. The precompile +-- verifies secp256k1 (ECDSA/@ecrecover@) signatures included directly in an +-- instruction's data against a message and Ethereum address, also included +-- in that data; it does not compute a signature itself. Signing (producing +-- the signature and recovery id from a private key) is out of scope for this +-- SDK — callers must supply an already-computed signature. +module Network.Solana.NativePrograms.Secp256k1 where + +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BL +import Network.Solana.Core.Crypto (SolanaPublicKey) +import Network.Solana.Core.Instruction + +-- | Secp256k1 native precompile program address. +secp256k1ProgramId :: SolanaPublicKey +secp256k1ProgramId = "KeccakSecp256k11111111111111111111111111111" + +-- | Offsets (within the transaction's instructions) of the signature, +-- Ethereum address, and message data used to verify a single secp256k1 +-- signature. The u8 instruction indexes are absolute indexes into the +-- transaction's instruction list; index @0@ means the transaction's FIRST +-- instruction. Serialized as an 11-byte little-endian packed struct, +-- matching the Rust SDK layout. +data SecpSignatureOffsets = SecpSignatureOffsets + { -- | Offset to the [signature, recovery_id] bytes (64 + 1 bytes). + ssoSignatureOffset :: Word16, + -- | Instruction index to find the signature. + ssoSignatureInstructionIndex :: Word8, + -- | Offset to the Ethereum address (20 bytes). + ssoEthAddressOffset :: Word16, + -- | Instruction index to find the Ethereum address. + ssoEthAddressInstructionIndex :: Word8, + -- | Offset to the start of the message data. + ssoMessageDataOffset :: Word16, + -- | Size of the message data, in bytes. + ssoMessageDataSize :: Word16, + -- | Instruction index to find the message data. + ssoMessageInstructionIndex :: Word8 + } + deriving (Eq, Show) + +instance Binary SecpSignatureOffsets where + put :: SecpSignatureOffsets -> Put + put (SecpSignatureOffsets sigOffset sigIdx ethOffset ethIdx msgOffset msgSize msgIdx) = do + putWord16le sigOffset + putWord8 sigIdx + putWord16le ethOffset + putWord8 ethIdx + putWord16le msgOffset + putWord16le msgSize + putWord8 msgIdx + + get :: Get SecpSignatureOffsets + get = + SecpSignatureOffsets + <$> getWord16le + <*> getWord8 + <*> getWord16le + <*> getWord8 + <*> getWord16le + <*> getWord16le + <*> getWord8 + +-- | Secp256k1 instruction data: a pre-built byte string. The 'Binary' +-- instance mirrors 'Network.Solana.SplPrograms.Memo.MemoData': 'put' emits +-- the bytes verbatim (no discriminant, no length prefix) and 'get' consumes +-- all remaining input, so that 'mkInstruction' reproduces exactly the bytes +-- built by 'newSecp256k1Instruction'. +newtype Secp256k1InstructionData = Secp256k1InstructionData BS.ByteString + deriving (Eq, Show) + +instance Binary Secp256k1InstructionData where + put :: Secp256k1InstructionData -> Put + put (Secp256k1InstructionData bs) = putByteString bs + get :: Get Secp256k1InstructionData + get = Secp256k1InstructionData . BL.toStrict <$> getRemainingLazyByteString + +-- | Creates a Secp256k1 signature-verification instruction that checks a +-- single, precomputed ECDSA signature: this SDK's counterpart of the Rust +-- SDK's @new_secp256k1_instruction_with_signature@. Receives the 20-byte +-- Ethereum address the signature is expected to recover to, the 64-byte +-- compact ECDSA signature, the recovery id, and the RAW message bytes: the +-- precompile applies Keccak-256 to the message itself during verification, +-- so the supplied signature must have been produced over +-- @keccak256(message)@. The signature, address, and message are all +-- embedded in this single instruction's data (instruction index @0@), so +-- the precompile takes no accounts. +-- +-- The recovery id selects which public key the signature recovers to; only +-- values 0-3 verify on-chain, but that range is not validated here, +-- matching the Rust builder. +-- +-- Throws via 'error' if @ethAddress@ is not exactly 20 bytes or @signature@ +-- is not exactly 64 bytes, mirroring the assertions in the Rust builder. +-- +-- The built instruction hardcodes all instruction indexes to 0, so it must +-- be placed as the FIRST instruction of the transaction for verification to +-- read its own embedded data (matching the Rust SDK's +-- @new_secp256k1_instruction@). +newSecp256k1Instruction :: BS.ByteString -> BS.ByteString -> Word8 -> BS.ByteString -> Instruction +newSecp256k1Instruction ethAddress signature recoveryId message + | BS.length ethAddress /= 20 = + error ("newSecp256k1Instruction: ethAddress must be 20 bytes, got " <> show (BS.length ethAddress)) + | BS.length signature /= 64 = + error ("newSecp256k1Instruction: signature must be 64 bytes, got " <> show (BS.length signature)) + | otherwise = + mkInstruction secp256k1ProgramId [] (Secp256k1InstructionData (BL.toStrict (runPut body))) + where + offsets = + SecpSignatureOffsets + { ssoSignatureOffset = 32, + ssoSignatureInstructionIndex = 0, + ssoEthAddressOffset = 12, + ssoEthAddressInstructionIndex = 0, + ssoMessageDataOffset = 97, + ssoMessageDataSize = fromIntegral (BS.length message), + ssoMessageInstructionIndex = 0 + } + body = do + putWord8 1 -- count: a single signature to verify + put offsets + putByteString ethAddress + putByteString signature + putWord8 recoveryId + putByteString message diff --git a/src/Network/Solana/NativePrograms/Stake.hs b/src/Network/Solana/NativePrograms/Stake.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/NativePrograms/Stake.hs @@ -0,0 +1,415 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Client for the Stake program. Instruction data is bincode-encoded +-- (u32 little-endian discriminant), like the System Program. +-- Covered discriminants: 0-7, 9, 10, 13; the seed-authority variants (8, 11), +-- SetLockupChecked (12), DeactivateDelinquent (14) and the deprecated +-- Redelegate (15) are not modeled. +module Network.Solana.NativePrograms.Stake where + +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BL +import Data.Int (Int64) +import GHC.Generics (Generic) +import Network.Solana.Core.Crypto +import Network.Solana.Core.Instruction +import Network.Solana.Sysvar qualified as Sysvar + +-- | Stake program address. +stakeProgramId :: SolanaPublicKey +stakeProgramId = "Stake11111111111111111111111111111111111111" + +-- | Stake config account address (legacy; still passed to DelegateStake). +stakeConfigId :: SolanaPublicKey +stakeConfigId = "StakeConfig11111111111111111111111111111111" + +-- | The authorities of a stake account. +data Authorized = Authorized + { aStaker :: SolanaPublicKey, + aWithdrawer :: SolanaPublicKey + } + deriving (Eq, Show, Generic) + +instance Binary Authorized where + put :: Authorized -> Put + put (Authorized staker withdrawer) = do + putByteString (getSolanaPublicKeyRaw staker) + putByteString (getSolanaPublicKeyRaw withdrawer) + get :: Get Authorized + get = Authorized <$> get <*> get + +-- | Lockup constraints on a stake account. +data Lockup = Lockup + { lUnixTimestamp :: Int64, + lEpoch :: Word64, + lCustodian :: SolanaPublicKey + } + deriving (Eq, Show, Generic) + +instance Binary Lockup where + put :: Lockup -> Put + put (Lockup ts epoch cust) = do + putInt64le ts + putWord64le epoch + putByteString (getSolanaPublicKeyRaw cust) + get :: Get Lockup + get = Lockup <$> getInt64le <*> getWord64le <*> get + +-- | A stake's delegation to a vote account. +data StakeDelegation = StakeDelegation + { sdVoter :: SolanaPublicKey, + sdStake :: Word64, + sdActivationEpoch :: Word64, + sdDeactivationEpoch :: Word64, + sdWarmupCooldownRate :: Double + } + deriving (Eq, Show) + +-- | A stake account's metadata: rent-exempt reserve, authorities, and lockup. +data StakeMeta = StakeMeta + { smRentExemptReserve :: Word64, + smAuthorized :: Authorized, + smLockup :: Lockup + } + deriving (Eq, Show) + +-- | A stake account's on-chain state (bincode-encoded @StakeStateV2@). +data StakeState + = StakeUninitialized + | StakeInitialized StakeMeta + | -- | Meta, delegation, credits observed, stake flags (wire order). + StakeActive StakeMeta StakeDelegation Word64 Word8 + | StakeRewardsPool + deriving (Eq, Show) + +-- | Decodes a stake account's data: a u32 discriminant (0 uninitialized, +-- 1 initialized, 2 active/delegated, 3 rewards pool). Trailing bytes +-- (account padding) are allowed. +decodeStakeAccount :: BS.ByteString -> Either String StakeState +decodeStakeAccount bs = case runGetOrFail getStakeState (BL.fromStrict bs) of + Left (_, _, err) -> Left err + Right (_, _, s) -> Right s + where + getStakeState = do + disc <- getWord32le + case disc of + 0 -> pure StakeUninitialized + 1 -> StakeInitialized <$> getMeta + 2 -> StakeActive <$> getMeta <*> getDelegation <*> getWord64le <*> getWord8 + 3 -> pure StakeRewardsPool + _ -> fail ("StakeState: unknown discriminant " <> show disc) + getMeta = StakeMeta <$> getWord64le <*> get <*> get + getDelegation = + StakeDelegation + <$> get + <*> getWord64le + <*> getWord64le + <*> getWord64le + <*> getDoublele + +-- | Which stake authority an operation concerns (bincode u32: 0 staker, 1 withdrawer). +data StakeAuthorize = AuthorizeStaker | AuthorizeWithdrawer + deriving (Eq, Show, Enum, Bounded, Generic) + +putStakeAuthorize :: StakeAuthorize -> Put +putStakeAuthorize sa = putWord32le (fromIntegral (fromEnum sa)) + +getStakeAuthorize :: Get StakeAuthorize +getStakeAuthorize = do + v <- getWord32le + if v <= 1 + then pure (toEnum (fromIntegral v)) + else fail ("StakeAuthorize: invalid value " <> show v) + +-- | Partial lockup update; bincode Option fields (u8 tag + value). +data LockupArgs = LockupArgs + { laUnixTimestamp :: Maybe Int64, + laEpoch :: Maybe Word64, + laCustodian :: Maybe SolanaPublicKey + } + deriving (Eq, Show, Generic) + +-- | bincode Option: u8 tag 0 (None) | 1 followed by T. +putBincodeOption :: (a -> Put) -> Maybe a -> Put +putBincodeOption _ Nothing = putWord8 0 +putBincodeOption p (Just x) = putWord8 1 >> p x + +getBincodeOption :: Get a -> Get (Maybe a) +getBincodeOption g = do + tag <- getWord8 + case tag of + 0 -> pure Nothing + 1 -> Just <$> g + _ -> fail ("bincode Option: invalid tag " <> show tag) + +instance Binary LockupArgs where + put :: LockupArgs -> Put + put (LockupArgs ts epoch cust) = do + putBincodeOption putInt64le ts + putBincodeOption putWord64le epoch + putBincodeOption (putByteString . getSolanaPublicKeyRaw) cust + get :: Get LockupArgs + get = + LockupArgs + <$> getBincodeOption getInt64le + <*> getBincodeOption getWord64le + <*> getBincodeOption get + +-- | Stake program instructions (covered subset). +data StakeInstruction + = Initialize Authorized Lockup + | Authorize SolanaPublicKey StakeAuthorize + | DelegateStake + | Split Word64 + | Withdraw Word64 + | Deactivate + | SetLockup LockupArgs + | Merge + | InitializeChecked + | AuthorizeChecked StakeAuthorize + | GetMinimumDelegation + deriving (Eq, Show, Generic) + +instance Binary StakeInstruction where + put :: StakeInstruction -> Put + put (Initialize authorized lockup) = do + putWord32le 0 + put authorized + put lockup + put (Authorize newAuthority stakeAuthorize) = do + putWord32le 1 + putByteString (getSolanaPublicKeyRaw newAuthority) + putStakeAuthorize stakeAuthorize + put DelegateStake = putWord32le 2 + put (Split amount) = do + putWord32le 3 + putWord64le amount + put (Withdraw amount) = do + putWord32le 4 + putWord64le amount + put Deactivate = putWord32le 5 + put (SetLockup args) = do + putWord32le 6 + put args + put Merge = putWord32le 7 + put InitializeChecked = putWord32le 9 + put (AuthorizeChecked stakeAuthorize) = do + putWord32le 10 + putStakeAuthorize stakeAuthorize + put GetMinimumDelegation = putWord32le 13 + + get :: Get StakeInstruction + get = do + disc <- getWord32le + case disc of + 0 -> Initialize <$> get <*> get + 1 -> Authorize <$> get <*> getStakeAuthorize + 2 -> pure DelegateStake + 3 -> Split <$> getWord64le + 4 -> Withdraw <$> getWord64le + 5 -> pure Deactivate + 6 -> SetLockup <$> get + 7 -> pure Merge + 9 -> pure InitializeChecked + 10 -> AuthorizeChecked <$> getStakeAuthorize + 13 -> pure GetMinimumDelegation + _ -> fail ("StakeInstruction: unknown discriminant " <> show disc) + +-- | Creates instruction to "Initialize a stake with lockup and authorization information" +-- Receives the new stake account, the authorized staker/withdrawer and the lockup. +-- # Account references +-- 0. `[WRITE]` Uninitialized stake account +-- 1. `[]` Rent sysvar +initialize :: SolanaPublicKey -> Authorized -> Lockup -> Instruction +initialize stakeAccount authorized lockup = + mkInstruction + stakeProgramId + [ AccountMeta {accountPubKey = stakeAccount, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = Sysvar.rent, isSigner = False, isWritable = False} + ] + (Initialize authorized lockup) + +-- | Creates instruction to "Authorize a key to manage stake or withdrawal" +-- Receives the stake account, the current stake or withdraw authority, the new authority, +-- which authority is being changed and, if updating the withdrawer before lockup expiration, +-- the lockup custodian. +-- # Account references +-- 0. `[WRITE]` Stake account to be updated +-- 1. `[]` Clock sysvar +-- 2. `[SIGNER]` The stake or withdraw authority +-- 3. `[SIGNER]` (optional) Lockup authority, if updating StakeAuthorize::Withdrawer before lockup expiration +authorize :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> StakeAuthorize -> Maybe SolanaPublicKey -> Instruction +authorize stakeAccount currentAuthority newAuthority stakeAuthorize custodian = + mkInstruction + stakeProgramId + ( [ AccountMeta {accountPubKey = stakeAccount, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = Sysvar.clock, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = currentAuthority, isSigner = True, isWritable = False} + ] + ++ maybe [] (\c -> [AccountMeta {accountPubKey = c, isSigner = True, isWritable = False}]) custodian + ) + (Authorize newAuthority stakeAuthorize) + +-- | Creates instruction to "Delegate a stake to a particular vote account" +-- Receives the stake account, the authorized staker and the vote account. +-- # Account references +-- 0. `[WRITE]` Initialized stake account to be delegated +-- 1. `[]` Vote account to which this stake will be delegated +-- 2. `[]` Clock sysvar +-- 3. `[]` Stake history sysvar +-- 4. `[]` Address of config account that carries stake config +-- 5. `[SIGNER]` Stake authority +delegateStake :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> Instruction +delegateStake stakeAccount stakeAuthority voteAccount = + mkInstruction + stakeProgramId + [ AccountMeta {accountPubKey = stakeAccount, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = voteAccount, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = Sysvar.clock, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = Sysvar.stakeHistory, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = stakeConfigId, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = stakeAuthority, isSigner = True, isWritable = False} + ] + DelegateStake + +-- | Creates instruction to "Split u64 tokens and stake off a stake account into another stake account" +-- Receives the stake account to split from, the uninitialized stake account that will take the +-- split-off amount, the stake authority and the number of lamports to split. +-- The destination account must already be allocated with 200 bytes and assigned to the stake +-- program (compose with the System Program client's createAccount/allocate+assign); the Rust +-- SDK's composite @split@ helper emits those instructions automatically, this builder does not. +-- # Account references +-- 0. `[WRITE]` Stake account to be split; must be in the Initialized or Stake state +-- 1. `[WRITE]` Uninitialized stake account that will take the split-off amount +-- 2. `[SIGNER]` Stake authority +split :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> Word64 -> Instruction +split stakeAccount splitStakeAccount stakeAuthority amount = + mkInstruction + stakeProgramId + [ AccountMeta {accountPubKey = stakeAccount, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = splitStakeAccount, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = stakeAuthority, isSigner = True, isWritable = False} + ] + (Split amount) + +-- | Creates instruction to "Withdraw unstaked lamports from the stake account" +-- Receives the stake account, the recipient account, the withdraw authority, the number of +-- lamports to withdraw and, if withdrawing before lockup expiration, the lockup custodian. +-- # Account references +-- 0. `[WRITE]` Stake account from which to withdraw +-- 1. `[WRITE]` Recipient account +-- 2. `[]` Clock sysvar +-- 3. `[]` Stake history sysvar +-- 4. `[SIGNER]` Withdraw authority +-- 5. `[SIGNER]` (optional) Lockup authority, if before lockup expiration +withdraw :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> Word64 -> Maybe SolanaPublicKey -> Instruction +withdraw stakeAccount recipient withdrawAuthority amount custodian = + mkInstruction + stakeProgramId + ( [ AccountMeta {accountPubKey = stakeAccount, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = recipient, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = Sysvar.clock, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = Sysvar.stakeHistory, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = withdrawAuthority, isSigner = True, isWritable = False} + ] + ++ maybe [] (\c -> [AccountMeta {accountPubKey = c, isSigner = True, isWritable = False}]) custodian + ) + (Withdraw amount) + +-- | Creates instruction to "Deactivate the stake in the account" +-- Receives the stake account and the stake authority. +-- # Account references +-- 0. `[WRITE]` Delegated stake account +-- 1. `[]` Clock sysvar +-- 2. `[SIGNER]` Stake authority +deactivate :: SolanaPublicKey -> SolanaPublicKey -> Instruction +deactivate stakeAccount stakeAuthority = + mkInstruction + stakeProgramId + [ AccountMeta {accountPubKey = stakeAccount, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = Sysvar.clock, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = stakeAuthority, isSigner = True, isWritable = False} + ] + Deactivate + +-- | Creates instruction to "Set stake lockup" +-- Receives the stake account, the lockup fields to update, and the lockup custodian +-- (or, if no lockup is currently in force, the withdraw authority). +-- # Account references +-- 0. `[WRITE]` Stake account +-- 1. `[SIGNER]` Lockup authority or withdraw authority +setLockup :: SolanaPublicKey -> LockupArgs -> SolanaPublicKey -> Instruction +setLockup stakeAccount lockupArgs custodian = + mkInstruction + stakeProgramId + [ AccountMeta {accountPubKey = stakeAccount, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = custodian, isSigner = True, isWritable = False} + ] + (SetLockup lockupArgs) + +-- | Creates instruction to "Merge two stake accounts" +-- Receives the destination stake account, the source stake account (which is merged into the +-- destination and deactivated) and the stake authority. +-- # Account references +-- 0. `[WRITE]` Destination stake account for the merge +-- 1. `[WRITE]` Source stake account for the merge +-- 2. `[]` Clock sysvar +-- 3. `[]` Stake history sysvar +-- 4. `[SIGNER]` Stake authority +merge :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> Instruction +merge destinationStakeAccount sourceStakeAccount stakeAuthority = + mkInstruction + stakeProgramId + [ AccountMeta {accountPubKey = destinationStakeAccount, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = sourceStakeAccount, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = Sysvar.clock, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = Sysvar.stakeHistory, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = stakeAuthority, isSigner = True, isWritable = False} + ] + Merge + +-- | Creates instruction to "Initialize a stake with authorization information", checking that the +-- withdrawer signs (a safer version of 'initialize'). +-- Receives the new stake account and the authorized staker/withdrawer; the withdrawer must sign. +-- # Account references +-- 0. `[WRITE]` Uninitialized stake account +-- 1. `[]` Rent sysvar +-- 2. `[]` The stake authority +-- 3. `[SIGNER]` The withdraw authority +initializeChecked :: SolanaPublicKey -> Authorized -> Instruction +initializeChecked stakeAccount authorized = + mkInstruction + stakeProgramId + [ AccountMeta {accountPubKey = stakeAccount, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = Sysvar.rent, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = aStaker authorized, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = aWithdrawer authorized, isSigner = True, isWritable = False} + ] + InitializeChecked + +-- | Creates instruction to "Authorize a key to manage stake or withdrawal", checking that the new +-- authority signs (a safer version of 'authorize'). +-- Receives the stake account, the current stake or withdraw authority, the new authority (which +-- must sign), which authority is being changed and, if updating the withdrawer before lockup +-- expiration, the lockup custodian. +-- # Account references +-- 0. `[WRITE]` Stake account to be updated +-- 1. `[]` Clock sysvar +-- 2. `[SIGNER]` The stake or withdraw authority +-- 3. `[SIGNER]` The new stake or withdraw authority +-- 4. `[SIGNER]` (optional) Lockup authority, if updating StakeAuthorize::Withdrawer before lockup expiration +authorizeChecked :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> StakeAuthorize -> Maybe SolanaPublicKey -> Instruction +authorizeChecked stakeAccount currentAuthority newAuthority stakeAuthorize custodian = + mkInstruction + stakeProgramId + ( [ AccountMeta {accountPubKey = stakeAccount, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = Sysvar.clock, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = currentAuthority, isSigner = True, isWritable = False}, + AccountMeta {accountPubKey = newAuthority, isSigner = True, isWritable = False} + ] + ++ maybe [] (\c -> [AccountMeta {accountPubKey = c, isSigner = True, isWritable = False}]) custodian + ) + (AuthorizeChecked stakeAuthorize) diff --git a/src/Network/Solana/NativePrograms/SystemProgram.hs b/src/Network/Solana/NativePrograms/SystemProgram.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/NativePrograms/SystemProgram.hs @@ -0,0 +1,456 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.Solana.NativePrograms.SystemProgram where + +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BL +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import GHC.Generics +import Network.Solana.Core.Account (Lamport) +import Network.Solana.Core.Block (BlockHash) +import Network.Solana.Core.Crypto +import Network.Solana.Core.Instruction +import Network.Solana.Sysvar qualified as Sysvar + +-- | System program address. This program contain instructions to: +-- create new accounts, allocate account data, assign accounts to owning programs, +-- transfer lamports from System Program owned accounts and pay transaction fees. +systemProgramId :: SolanaPublicKey +systemProgramId = "11111111111111111111111111111111" + +data SystemInstruction + = -- | Create a new account + CreateAccount + { -- | Number of lamports to transfer to the new account + lamports :: Word64, + -- | Number of bytes of memory to allocate + space :: Word64, + -- | Address of program that will own the new account + owner :: SolanaPublicKey + } + | -- | Assign account to a program + Assign + { -- | Owner program account + owner :: SolanaPublicKey + } + | -- | Transfer lamports + Transfer + { -- | Transfer amount + lamports :: Word64 + } + | CreateAccountWithSeed + { -- | Base public key + base :: SolanaPublicKey, + -- | String of ASCII chars, no longer than 'Network.Solana.Constants.maxSeedLen' + seed :: String, + -- | Number of lamports to transfer to the new account + lamports :: Word64, + -- | Number of bytes of memory to allocate + space :: Word64, + -- | Address of program that will own the new account + owner :: SolanaPublicKey + } + | -- | Consume a stored nonce, replacing it with a successor + AdvanceNonceAccount + | -- | Withdraw funds from a nonce account + WithdrawNonceAccount + { -- | Withdraw amount + lamports :: Word64 + } + | -- | Drive state of Uninitialized nonce account to Initialized, setting the nonce value + InitializeNonceAccount + { -- | Entity authorized to execute nonce instructions on the account + authority :: SolanaPublicKey + } + | -- | Change the entity authorized to execute nonce instructions on the account + AuthorizeNonceAccount + { -- | New nonce authority + authority :: SolanaPublicKey + } + | -- | Allocate space in a (possibly new) account without funding + Allocate + { -- | Number of bytes of memory to allocate + space :: Word64 + } + | -- | Allocate space for and assign an account at an address derived from a base public key and a seed + AllocateWithSeed + { -- | Base public key + base :: SolanaPublicKey, + -- | String of ASCII chars, no longer than 'Network.Solana.Constants.maxSeedLen' + seed :: String, + -- | Number of bytes of memory to allocate + space :: Word64, + -- | Address of program that will own the account + owner :: SolanaPublicKey + } + | -- | Assign account to a program based on a seed + AssignWithSeed + { -- | Base public key + base :: SolanaPublicKey, + -- | String of ASCII chars, no longer than 'Network.Solana.Constants.maxSeedLen' + seed :: String, + -- | Owner program account + owner :: SolanaPublicKey + } + | -- | Transfer lamports from a derived address + TransferWithSeed + { -- | Transfer amount + lamports :: Word64, + -- | Seed to use to derive the funding account address + fromSeed :: String, + -- | Owner to use to derive the funding account address + fromOwner :: SolanaPublicKey + } + | -- | One-time idempotent upgrade of legacy nonce versions to bump them out of chain blockhash domain + UpgradeNonceAccount + deriving (Eq, Show, Generic) + +instance Binary SystemInstruction where + put :: SystemInstruction -> Put + put (CreateAccount lamports space owner) = do + putWord32le (0 :: Word32) + putWord64le lamports + putWord64le space + putByteString (getSolanaPublicKeyRaw owner) + put (Assign owner) = do + putWord32le (1 :: Word32) + putByteString (getSolanaPublicKeyRaw owner) + put (Transfer lamports) = do + putWord32le (2 :: Word32) + putWord64le lamports + put (CreateAccountWithSeed base seed lamports space owner) = do + putWord32le (3 :: Word32) + putByteString (getSolanaPublicKeyRaw base) + putBincodeString seed + putWord64le lamports + putWord64le space + putByteString (getSolanaPublicKeyRaw owner) + put AdvanceNonceAccount = + putWord32le (4 :: Word32) + put (WithdrawNonceAccount lamports) = do + putWord32le (5 :: Word32) + putWord64le lamports + put (InitializeNonceAccount authority) = do + putWord32le (6 :: Word32) + putByteString (getSolanaPublicKeyRaw authority) + put (AuthorizeNonceAccount authority) = do + putWord32le (7 :: Word32) + putByteString (getSolanaPublicKeyRaw authority) + put (Allocate space) = do + putWord32le (8 :: Word32) + putWord64le space + put (AllocateWithSeed base seed space owner) = do + putWord32le (9 :: Word32) + putByteString (getSolanaPublicKeyRaw base) + putBincodeString seed + putWord64le space + putByteString (getSolanaPublicKeyRaw owner) + put (AssignWithSeed base seed owner) = do + putWord32le (10 :: Word32) + putByteString (getSolanaPublicKeyRaw base) + putBincodeString seed + putByteString (getSolanaPublicKeyRaw owner) + put (TransferWithSeed lamports fromSeed fromOwner) = do + putWord32le (11 :: Word32) + putWord64le lamports + putBincodeString fromSeed + putByteString (getSolanaPublicKeyRaw fromOwner) + put UpgradeNonceAccount = + putWord32le (12 :: Word32) + + get :: Get SystemInstruction + get = do + disc <- getWord32le + case disc of + 0 -> CreateAccount <$> getWord64le <*> getWord64le <*> get + 1 -> Assign <$> get + 2 -> Transfer <$> getWord64le + 3 -> CreateAccountWithSeed <$> get <*> getBincodeString <*> getWord64le <*> getWord64le <*> get + 4 -> pure AdvanceNonceAccount + 5 -> WithdrawNonceAccount <$> getWord64le + 6 -> InitializeNonceAccount <$> get + 7 -> AuthorizeNonceAccount <$> get + 8 -> Allocate <$> getWord64le + 9 -> AllocateWithSeed <$> get <*> getBincodeString <*> getWord64le <*> get + 10 -> AssignWithSeed <$> get <*> getBincodeString <*> get + 11 -> TransferWithSeed <$> getWord64le <*> getBincodeString <*> get + 12 -> pure UpgradeNonceAccount + _ -> fail ("SystemInstruction: unknown discriminant " <> show disc) + +-- bincode encodes a Rust String as a u64 little-endian byte length +-- followed by the UTF-8 bytes +putBincodeString :: String -> Put +putBincodeString s = do + let bs = TE.encodeUtf8 (T.pack s) + putWord64le (fromIntegral (BS.length bs)) + putByteString bs + +-- | bincode decodes a Rust String as a u64 little-endian byte length +-- followed by that many UTF-8 bytes. +getBincodeString :: Get String +getBincodeString = do + len <- getWord64le + if len > fromIntegral (maxBound :: Int) + then fail "getBincodeString: length exceeds Int range" + else do + bs <- getByteString (fromIntegral len) + case TE.decodeUtf8' bs of + Left _ -> fail "getBincodeString: invalid UTF-8" + Right t -> pure (T.unpack t) + +-- | A nonce account's on-chain state (bincode-encoded @Versions@: +-- a u32 version tag around a u32 state tag). +data NonceState + = NonceUninitialized + | NonceInitialized + { nsAuthority :: SolanaPublicKey, + nsDurableNonce :: BlockHash, + nsLamportsPerSignature :: Word64 + } + deriving (Eq, Show) + +-- | Decodes a nonce account's data: a u32 version (0 or 1), then a u32 state +-- discriminant (0 uninitialized, 1 initialized with authority, durable +-- nonce, and fee-rate fields). Trailing bytes (account padding) are allowed. +decodeNonceAccount :: BS.ByteString -> Either String NonceState +decodeNonceAccount bs = case runGetOrFail getNonceState (BL.fromStrict bs) of + Left (_, _, err) -> Left err + Right (_, _, ns) -> Right ns + where + getNonceState = do + version <- getWord32le + if version /= 0 && version /= 1 + then fail ("NonceState: unsupported version " <> show version) + else do + st <- getWord32le + case st of + 0 -> pure NonceUninitialized + 1 -> NonceInitialized <$> get <*> get <*> getWord64le + _ -> fail ("NonceState: unknown state " <> show st) + +-- | Creates instruction to "Create a new account" +-- Receives the funding account, the new account, amount to transfer, the number of bytes of memory to allocate and the owner program account. +-- # Account references +-- 0. `[WRITE, SIGNER]` Funding account +-- 1. `[WRITE, SIGNER]` New account +createAccount :: SolanaPublicKey -> SolanaPublicKey -> Lamport -> Int -> SolanaPublicKey -> Instruction +createAccount fundingAccount newAccount lamports space ownerProgramAccount = + mkInstruction + systemProgramId + [ AccountMeta + { accountPubKey = fundingAccount, + isSigner = True, + isWritable = True + }, + AccountMeta + { accountPubKey = newAccount, + isSigner = True, + isWritable = True + } + ] + (CreateAccount (fromIntegral lamports) (fromIntegral space) ownerProgramAccount) + +-- | Creates instruction to "Assign account to a program" +-- Receives addresses for the assigned account and owner program account +-- # Account references +-- 0. `[WRITE, SIGNER]` Assigned account public key +assignAccount :: SolanaPublicKey -> SolanaPublicKey -> Instruction +assignAccount assignedAccount ownerProgramAccount = + mkInstruction + systemProgramId + [ AccountMeta + { accountPubKey = assignedAccount, + isSigner = True, + isWritable = True + } + ] + (Assign ownerProgramAccount) + +-- | Creates instruction to "Transfer lamports" +-- Receives the funding account, the recipient account and the amount to transfer. +-- # Account references +-- 0. `[WRITE, SIGNER]` Funding account +-- 1. `[WRITE]` Recipient account +transfer :: SolanaPublicKey -> SolanaPublicKey -> Lamport -> Instruction +transfer fundingAccount recipientAccount amount = + mkInstruction + systemProgramId + [ AccountMeta + { accountPubKey = fundingAccount, + isSigner = True, + isWritable = True + }, + AccountMeta + { accountPubKey = recipientAccount, + isSigner = False, + isWritable = True + } + ] + (Transfer (fromIntegral amount)) + +-- | Creates instruction to "Create a new account at an address derived from a base pubkey and a seed" +-- Receives the funding account, the new account, base pubkey, seed, amount to transfer, the number of bytes of memory to allocate and the owner program account. +-- # Account references +-- 0. `[WRITE, SIGNER]` Funding account +-- 1. `[WRITE]` Created account +-- 2. `[SIGNER]` (optional) Base account; the account matching the base Pubkey below must be +-- provided as a signer, but may be the same as the funding account and provided as account 0 +createAccountWithSeed :: SolanaPublicKey -> String -> SolanaPublicKey -> SolanaPublicKey -> Lamport -> Int -> SolanaPublicKey -> Instruction +createAccountWithSeed baseAccount seed fundingAccount newAccount lamports space ownerProgramAccount = + mkInstruction + systemProgramId + [ AccountMeta + { accountPubKey = fundingAccount, + isSigner = True, + isWritable = True + }, + AccountMeta + { accountPubKey = newAccount, + isSigner = False, + isWritable = True + }, + AccountMeta + { accountPubKey = baseAccount, + isSigner = True, + isWritable = False + } + ] + (CreateAccountWithSeed baseAccount seed (fromIntegral lamports) (fromIntegral space) ownerProgramAccount) + +-- | Creates instruction to "Consume a stored nonce, replacing it with a successor" +-- Receives the nonce account and the nonce authority. +-- # Account references +-- 0. `[WRITE]` Nonce account +-- 1. `[]` RecentBlockhashes sysvar +-- 2. `[SIGNER]` Nonce authority +advanceNonceAccount :: SolanaPublicKey -> SolanaPublicKey -> Instruction +advanceNonceAccount nonceAccount nonceAuthority = + mkInstruction + systemProgramId + [ AccountMeta {accountPubKey = nonceAccount, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = Sysvar.recentBlockhashes, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = nonceAuthority, isSigner = True, isWritable = False} + ] + AdvanceNonceAccount + +-- | Creates instruction to "Withdraw funds from a nonce account" +-- Receives the nonce account, the nonce authority, the recipient account and the amount. +-- # Account references +-- 0. `[WRITE]` Nonce account +-- 1. `[WRITE]` Recipient account +-- 2. `[]` RecentBlockhashes sysvar +-- 3. `[]` Rent sysvar +-- 4. `[SIGNER]` Nonce authority +withdrawNonceAccount :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> Lamport -> Instruction +withdrawNonceAccount nonceAccount nonceAuthority recipientAccount amount = + mkInstruction + systemProgramId + [ AccountMeta {accountPubKey = nonceAccount, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = recipientAccount, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = Sysvar.recentBlockhashes, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = Sysvar.rent, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = nonceAuthority, isSigner = True, isWritable = False} + ] + (WithdrawNonceAccount (fromIntegral amount)) + +-- | Creates instruction to "Drive state of Uninitialized nonce account to Initialized" +-- Receives the nonce account and the entity authorized to execute nonce instructions on it. +-- # Account references +-- 0. `[WRITE]` Nonce account +-- 1. `[]` RecentBlockhashes sysvar +-- 2. `[]` Rent sysvar +initializeNonceAccount :: SolanaPublicKey -> SolanaPublicKey -> Instruction +initializeNonceAccount nonceAccount nonceAuthority = + mkInstruction + systemProgramId + [ AccountMeta {accountPubKey = nonceAccount, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = Sysvar.recentBlockhashes, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = Sysvar.rent, isSigner = False, isWritable = False} + ] + (InitializeNonceAccount nonceAuthority) + +-- | Creates instruction to "Change the entity authorized to execute nonce instructions on the account" +-- Receives the nonce account, the current nonce authority and the new nonce authority. +-- # Account references +-- 0. `[WRITE]` Nonce account +-- 1. `[SIGNER]` Nonce authority +authorizeNonceAccount :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> Instruction +authorizeNonceAccount nonceAccount nonceAuthority newAuthority = + mkInstruction + systemProgramId + [ AccountMeta {accountPubKey = nonceAccount, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = nonceAuthority, isSigner = True, isWritable = False} + ] + (AuthorizeNonceAccount newAuthority) + +-- | Creates instruction to "Upgrade legacy nonce versions" +-- Receives the nonce account. +-- # Account references +-- 0. `[WRITE]` Nonce account +upgradeNonceAccount :: SolanaPublicKey -> Instruction +upgradeNonceAccount nonceAccount = + mkInstruction + systemProgramId + [ AccountMeta {accountPubKey = nonceAccount, isSigner = False, isWritable = True} + ] + UpgradeNonceAccount + +-- | Creates instruction to "Allocate space in a (possibly new) account without funding" +-- Receives the account and the number of bytes of memory to allocate. +-- # Account references +-- 0. `[WRITE, SIGNER]` New account +allocate :: SolanaPublicKey -> Int -> Instruction +allocate newAccount space = + mkInstruction + systemProgramId + [ AccountMeta {accountPubKey = newAccount, isSigner = True, isWritable = True} + ] + (Allocate (fromIntegral space)) + +-- | Creates instruction to "Allocate space for and assign an account at an address derived from a base public key and a seed" +-- Receives the allocated account, base account, seed, the number of bytes and the owner program account. +-- # Account references +-- 0. `[WRITE]` Allocated account +-- 1. `[SIGNER]` Base account +allocateWithSeed :: SolanaPublicKey -> SolanaPublicKey -> String -> Int -> SolanaPublicKey -> Instruction +allocateWithSeed allocatedAccount baseAccount seed space ownerProgramAccount = + mkInstruction + systemProgramId + [ AccountMeta {accountPubKey = allocatedAccount, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = baseAccount, isSigner = True, isWritable = False} + ] + (AllocateWithSeed baseAccount seed (fromIntegral space) ownerProgramAccount) + +-- | Creates instruction to "Assign account to a program based on a seed" +-- Receives the assigned account, base account, seed and the owner program account. +-- # Account references +-- 0. `[WRITE]` Assigned account +-- 1. `[SIGNER]` Base account +assignWithSeed :: SolanaPublicKey -> SolanaPublicKey -> String -> SolanaPublicKey -> Instruction +assignWithSeed assignedAccount baseAccount seed ownerProgramAccount = + mkInstruction + systemProgramId + [ AccountMeta {accountPubKey = assignedAccount, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = baseAccount, isSigner = True, isWritable = False} + ] + (AssignWithSeed baseAccount seed ownerProgramAccount) + +-- | Creates instruction to "Transfer lamports from a derived address" +-- Receives the funding account, base account, seed, the owner of the funding account, the recipient and the amount. +-- # Account references +-- 0. `[WRITE]` Funding account +-- 1. `[SIGNER]` Base for funding account +-- 2. `[WRITE]` Recipient account +transferWithSeed :: SolanaPublicKey -> SolanaPublicKey -> String -> SolanaPublicKey -> SolanaPublicKey -> Lamport -> Instruction +transferWithSeed fundingAccount baseAccount fromSeed fromOwner recipientAccount amount = + mkInstruction + systemProgramId + [ AccountMeta {accountPubKey = fundingAccount, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = baseAccount, isSigner = True, isWritable = False}, + AccountMeta {accountPubKey = recipientAccount, isSigner = False, isWritable = True} + ] + (TransferWithSeed (fromIntegral amount) fromSeed fromOwner) diff --git a/src/Network/Solana/NativePrograms/Vote.hs b/src/Network/Solana/NativePrograms/Vote.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/NativePrograms/Vote.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Client for the Vote program. Instruction data is bincode-encoded +-- (u32 little-endian discriminant), like the System and Stake programs. +-- Covered discriminants: 0, 1, 3, 4, 5, 7 (account-management surface); the +-- consensus @Vote@ instruction (2) and the remaining vote-state variants +-- (6, 8-15) are not modeled. +module Network.Solana.NativePrograms.Vote where + +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import GHC.Generics (Generic) +import Network.Solana.Core.Crypto +import Network.Solana.Core.Instruction +import Network.Solana.Sysvar qualified as Sysvar + +-- | Vote program address. +voteProgramId :: SolanaPublicKey +voteProgramId = "Vote111111111111111111111111111111111111111" + +-- | Arguments to initialize a vote account. +data VoteInit = VoteInit + { viNodePubkey :: SolanaPublicKey, + viAuthorizedVoter :: SolanaPublicKey, + viAuthorizedWithdrawer :: SolanaPublicKey, + viCommission :: Word8 + } + deriving (Eq, Show, Generic) + +instance Binary VoteInit where + put :: VoteInit -> Put + put (VoteInit node voter withdrawer commission) = do + putByteString (getSolanaPublicKeyRaw node) + putByteString (getSolanaPublicKeyRaw voter) + putByteString (getSolanaPublicKeyRaw withdrawer) + putWord8 commission + get :: Get VoteInit + get = VoteInit <$> get <*> get <*> get <*> getWord8 + +-- | Which vote authority an operation concerns (bincode u32: 0 voter, 1 withdrawer). +data VoteAuthorize = AuthorizeVoter | AuthorizeWithdrawer + deriving (Eq, Show, Enum, Bounded, Generic) + +putVoteAuthorize :: VoteAuthorize -> Put +putVoteAuthorize va = putWord32le (fromIntegral (fromEnum va)) + +getVoteAuthorize :: Get VoteAuthorize +getVoteAuthorize = do + v <- getWord32le + if v <= 1 + then pure (toEnum (fromIntegral v)) + else fail ("VoteAuthorize: invalid value " <> show v) + +-- | Vote program instructions (covered subset). +data VoteInstruction + = InitializeAccount VoteInit + | Authorize SolanaPublicKey VoteAuthorize + | Withdraw Word64 + | UpdateValidatorIdentity + | UpdateCommission Word8 + | AuthorizeChecked VoteAuthorize + deriving (Eq, Show, Generic) + +instance Binary VoteInstruction where + put :: VoteInstruction -> Put + put (InitializeAccount voteInit) = do + putWord32le 0 + put voteInit + put (Authorize newAuthority voteAuthorize) = do + putWord32le 1 + putByteString (getSolanaPublicKeyRaw newAuthority) + putVoteAuthorize voteAuthorize + put (Withdraw amount) = do + putWord32le 3 + putWord64le amount + put UpdateValidatorIdentity = putWord32le 4 + put (UpdateCommission commission) = do + putWord32le 5 + putWord8 commission + put (AuthorizeChecked voteAuthorize) = do + putWord32le 7 + putVoteAuthorize voteAuthorize + + get :: Get VoteInstruction + get = do + disc <- getWord32le + case disc of + 0 -> InitializeAccount <$> get + 1 -> Authorize <$> get <*> getVoteAuthorize + 3 -> Withdraw <$> getWord64le + 4 -> pure UpdateValidatorIdentity + 5 -> UpdateCommission <$> getWord8 + 7 -> AuthorizeChecked <$> getVoteAuthorize + _ -> fail ("VoteInstruction: unknown discriminant " <> show disc) + +-- | Creates instruction to "Initialize a vote account" +-- Receives the new vote account and the initialization arguments (node +-- identity, authorized voter/withdrawer and commission). +-- # Account references +-- 0. `[WRITE]` Uninitialized vote account +-- 1. `[]` Rent sysvar +-- 2. `[]` Clock sysvar +-- 3. `[SIGNER]` New validator identity (node) +initializeVoteAccount :: SolanaPublicKey -> VoteInit -> Instruction +initializeVoteAccount voteAccount voteInit = + mkInstruction + voteProgramId + [ AccountMeta {accountPubKey = voteAccount, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = Sysvar.rent, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = Sysvar.clock, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = viNodePubkey voteInit, isSigner = True, isWritable = False} + ] + (InitializeAccount voteInit) + +-- | Creates instruction to "Authorize a key to send votes or issue a withdrawal" +-- Receives the vote account, the current authority, the new authority and +-- which authority is being changed. +-- # Account references +-- 0. `[WRITE]` Vote account to be updated +-- 1. `[]` Clock sysvar +-- 2. `[SIGNER]` The vote or withdraw authority +authorizeVote :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> VoteAuthorize -> Instruction +authorizeVote voteAccount currentAuthority newAuthority voteAuthorize = + mkInstruction + voteProgramId + [ AccountMeta {accountPubKey = voteAccount, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = Sysvar.clock, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = currentAuthority, isSigner = True, isWritable = False} + ] + (Authorize newAuthority voteAuthorize) + +-- | Creates instruction to "Withdraw lamports from a vote account" +-- Receives the vote account, the recipient account, the withdraw authority +-- and the number of lamports to withdraw. +-- # Account references +-- 0. `[WRITE]` Vote account to withdraw from +-- 1. `[WRITE]` Recipient account +-- 2. `[SIGNER]` Withdraw authority +withdrawVote :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> Word64 -> Instruction +withdrawVote voteAccount recipient withdrawAuthority amount = + mkInstruction + voteProgramId + [ AccountMeta {accountPubKey = voteAccount, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = recipient, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = withdrawAuthority, isSigner = True, isWritable = False} + ] + (Withdraw amount) + +-- | Creates instruction to "Update the vote account's validator identity (node pubkey)" +-- Receives the vote account, the new validator identity (which must sign) and +-- the withdraw authority. +-- # Account references +-- 0. `[WRITE]` Vote account to be updated +-- 1. `[SIGNER]` New validator identity (node) +-- 2. `[SIGNER]` Withdraw authority +updateValidatorIdentity :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> Instruction +updateValidatorIdentity voteAccount newNode withdrawAuthority = + mkInstruction + voteProgramId + [ AccountMeta {accountPubKey = voteAccount, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = newNode, isSigner = True, isWritable = False}, + AccountMeta {accountPubKey = withdrawAuthority, isSigner = True, isWritable = False} + ] + UpdateValidatorIdentity + +-- | Creates instruction to "Update the vote account's commission" +-- Receives the vote account, the withdraw authority and the new commission. +-- # Account references +-- 0. `[WRITE]` Vote account to be updated +-- 1. `[SIGNER]` Withdraw authority +updateCommission :: SolanaPublicKey -> SolanaPublicKey -> Word8 -> Instruction +updateCommission voteAccount withdrawAuthority commission = + mkInstruction + voteProgramId + [ AccountMeta {accountPubKey = voteAccount, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = withdrawAuthority, isSigner = True, isWritable = False} + ] + (UpdateCommission commission) + +-- | Creates instruction to "Authorize a key to send votes or issue a withdrawal", checking +-- that the new authority signs (a safer version of 'authorizeVote'). +-- Receives the vote account, the current authority, the new authority (which +-- must sign) and which authority is being changed. +-- # Account references +-- 0. `[WRITE]` Vote account to be updated +-- 1. `[]` Clock sysvar +-- 2. `[SIGNER]` The vote or withdraw authority +-- 3. `[SIGNER]` The new vote or withdraw authority +authorizeVoteChecked :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> VoteAuthorize -> Instruction +authorizeVoteChecked voteAccount currentAuthority newAuthority voteAuthorize = + mkInstruction + voteProgramId + [ AccountMeta {accountPubKey = voteAccount, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = Sysvar.clock, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = currentAuthority, isSigner = True, isWritable = False}, + AccountMeta {accountPubKey = newAuthority, isSigner = True, isWritable = False} + ] + (AuthorizeChecked voteAuthorize) diff --git a/src/Network/Solana/RPC/HTTP/Account.hs b/src/Network/Solana/RPC/HTTP/Account.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/RPC/HTTP/Account.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Solana.RPC.HTTP.Account +-- Description : Solana RPC methods for retrieving account-related data. +-- +-- This module provides bindings to various Solana JSON-RPC methods +-- for fetching account information, balances, transaction signatures, +-- and related metadata. +module Network.Solana.RPC.HTTP.Account where + +import Data.Aeson +import Data.Aeson.Types +import Data.Int (Int64) +import GHC.Generics (Generic) +import Network.JsonRpc.TinyClient (JsonRpc (..)) +import Network.Solana.Core.Account (Account, AccountInfo, Lamport) +import Network.Solana.Core.Crypto (SolanaPublicKey, SolanaSignature) +import Network.Solana.RPC.HTTP.Types + +------------------------------------------------------------------------------------------------ + +-- ** getAccountInfo + +------------------------------------------------------------------------------------------------ + +-- | Fetches all available data for the given account address, using the given configuration. +-- Returns 'RPCResponse' ('Maybe' 'AccountInfo'), where 'Nothing' indicates the account does not exist. +getAccountInfo' :: (JsonRpc m) => SolanaPublicKey -> ConfigurationObject -> m (RPCResponse (Maybe AccountInfo)) +getAccountInfo' = do + remote "getAccountInfo" +{-# INLINE getAccountInfo' #-} + +-- | Fetches all available data for the given account address, requesting +-- base64 encoding (the node's default base58 encoding rejects account data +-- over 128 bytes). Returns 'Nothing' if the account does not exist. +getAccountInfo :: (JsonRpc m) => SolanaPublicKey -> m (Maybe AccountInfo) +getAccountInfo pubKey = value <$> getAccountInfo' pubKey cfgJustEncodingBase64 +{-# INLINE getAccountInfo #-} + +------------------------------------------------------------------------------------------------ + +-- ** getBalance + +------------------------------------------------------------------------------------------------ + +-- | Returns the balance, in lamports, of the specified account. +-- Returns 'RPCResponse' 'Lamport'. +getBalance' :: (JsonRpc m) => SolanaPublicKey -> m (RPCResponse Lamport) +getBalance' = do + remote "getBalance" +{-# INLINE getBalance' #-} + +-- | Returns the balance, in lamports, of the specified account. +getBalance :: (JsonRpc m) => SolanaPublicKey -> m Lamport +getBalance pubKey = value <$> getBalance' pubKey +{-# INLINE getBalance #-} + +------------------------------------------------------------------------------------------------ + +-- * getMultipleAccounts + +------------------------------------------------------------------------------------------------ + +-- | Returns account information for a list of addresses, using the given configuration. +-- For any missing account, the result contains 'Nothing' in its place. +getMultipleAccounts' :: (JsonRpc m) => [SolanaPublicKey] -> ConfigurationObject -> m (RPCResponse [Maybe AccountInfo]) +getMultipleAccounts' = do + remote "getMultipleAccounts" +{-# INLINE getMultipleAccounts' #-} + +-- | Returns account information for a list of addresses, requesting base64 +-- encoding (the node's default base58 encoding rejects account data over +-- 128 bytes). For any missing account, the result contains 'Nothing' in its place. +getMultipleAccounts :: (JsonRpc m) => [SolanaPublicKey] -> m [Maybe AccountInfo] +getMultipleAccounts pubKeys = value <$> getMultipleAccounts' pubKeys cfgJustEncodingBase64 +{-# INLINE getMultipleAccounts #-} + +------------------------------------------------------------------------------------------------ + +-- * getProgramAccounts + +------------------------------------------------------------------------------------------------ + +-- | Returns all accounts owned by the specified program address, using the given configuration. +getProgramAccounts' :: (JsonRpc m) => SolanaPublicKey -> ConfigurationObject -> m [Account] +getProgramAccounts' = do + remote "getProgramAccounts" +{-# INLINE getProgramAccounts' #-} + +-- | Returns all accounts owned by the specified program address, requesting +-- base64 encoding (the node's default base58 encoding rejects account data +-- over 128 bytes). +getProgramAccounts :: (JsonRpc m) => SolanaPublicKey -> m [Account] +getProgramAccounts pk = getProgramAccounts' pk cfgJustEncodingBase64 +{-# INLINE getProgramAccounts #-} + +------------------------------------------------------------------------------------------------ + +-- * getLargestAccounts + +------------------------------------------------------------------------------------------------ + +-- | Contains the address and value of an account. +data AddressAndLamports + = AddressAndLamports + { -- | Account address + address :: SolanaPublicKey, + -- | Number of lamports in the account + lamports :: Lamport + } + deriving (Generic, Show, FromJSON) + +-- | Returns up to the 20 accounts with the highest balances in lamports. +-- Results may be cached for up to two hours. +getLargestAccounts' :: (JsonRpc m) => m (RPCResponse [AddressAndLamports]) +getLargestAccounts' = do + remote "getLargestAccounts" +{-# INLINE getLargestAccounts' #-} + +-- | Returns up to the 20 accounts with the highest balances in lamports. +-- Results may be cached for up to two hours. +getLargestAccounts :: (JsonRpc m) => m [(SolanaPublicKey, Lamport)] +getLargestAccounts = fmap (liftA2 (,) address lamports) . value <$> getLargestAccounts' +{-# INLINE getLargestAccounts #-} + +------------------------------------------------------------------------------------------------ + +-- * getSignaturesForAddress + +------------------------------------------------------------------------------------------------ + +-- | Returns confirmed transaction signatures involving the given address, in reverse chronological order. +getSignaturesForAddress :: (JsonRpc m) => SolanaPublicKey -> m [TransactionSignatureInformation] +getSignaturesForAddress = do + remote "getSignaturesForAddress" +{-# INLINE getSignaturesForAddress #-} + +-- | Metadata for a confirmed transaction signature involving a given address. +data TransactionSignatureInformation = TransactionSignatureInformation + { -- | Transaction signature + signature :: SolanaSignature, + -- | The slot that contains the block with the transaction + slotTxSig :: Slot, + -- | Error details if the transaction failed ('Data.Aeson.Value' as + -- returned by the RPC), 'Nothing' if it succeeded. + err :: Maybe Value, + -- | Memo associated with the transaction, 'Nothing' if no memo is present + memo :: Maybe String, + -- | Estimated production time, as Unix timestamp (seconds since the Unix epoch) of when transaction was processed. 'Nothing' if not available. + blockTime :: Maybe Int64, + -- | The transaction's cluster confirmation status; + confirmationStatus :: Maybe String + } + deriving (Show) + +instance FromJSON TransactionSignatureInformation where + parseJSON :: Value -> Parser TransactionSignatureInformation + parseJSON = withObject "TransactionSignatureInformation" $ \v -> + TransactionSignatureInformation + <$> v .: "signature" + <*> v .: "slot" + <*> v .: "err" + <*> v .: "memo" + <*> v .: "blockTime" + <*> v .: "confirmationStatus" + +------------------------------------------------------------------------------------------------ + +-- * getSignatureStatuses + +------------------------------------------------------------------------------------------------ + +-- | Returns the confirmation status and slot info for the specified transaction signatures. +-- Each signature should be the transaction’s first signature (used as a unique identifier). +getSignatureStatuses' :: (JsonRpc m) => [SolanaSignature] -> ConfigurationObject -> m (RPCResponse [Maybe TransactionSignatureStatus]) +getSignatureStatuses' = do + remote "getSignatureStatuses" +{-# INLINE getSignatureStatuses' #-} + +-- | Returns the confirmation status and slot info for the specified transaction signatures. +-- Each signature should be the transaction’s first signature (used as a unique identifier). +getSignatureStatuses :: (JsonRpc m) => [SolanaSignature] -> m [Maybe TransactionSignatureStatus] +getSignatureStatuses sigs = value <$> getSignatureStatuses' sigs (defaultConfigObject {searchTransactionHistory = Just True}) +{-# INLINE getSignatureStatuses #-} + +-- | Status metadata for a given transaction signature. +data TransactionSignatureStatus = TransactionSignatureStatus + { -- | The slot the transaction was processed + slotTxStatus :: Slot, + -- | Number of blocks since signature confirmation, 'Nothing' if rooted, as well as finalized by a supermajority of the cluster. + confirmationsTxStatus :: Maybe Int, + -- | Error details if the transaction failed ('Data.Aeson.Value' as + -- returned by the RPC), 'Nothing' if it succeeded. + errTxStatus :: Maybe Value, + -- | The transaction's cluster confirmation status. + confirmationStatusTxStatus :: Maybe String + } + deriving (Generic, Show) + +instance FromJSON TransactionSignatureStatus where + parseJSON :: Value -> Parser TransactionSignatureStatus + parseJSON = withObject "TransactionSignatureStatus" $ \v -> + TransactionSignatureStatus + <$> v .: "slot" + <*> v .: "confirmations" + <*> v .: "err" + <*> v .: "confirmationStatus" diff --git a/src/Network/Solana/RPC/HTTP/Block.hs b/src/Network/Solana/RPC/HTTP/Block.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/RPC/HTTP/Block.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Solana.RPC.HTTP.Block +-- Description : Solana RPC methods for accessing block-related information. +-- +-- This module provides access to block-related JSON-RPC methods in the Solana network. +-- These include fetching full block data, commitment levels, recent block production statistics, +-- block ranges, timestamps, and validity of blockhashes. Useful for exploring historical blocks, +-- validator performance, and transaction confirmation metadata. +module Network.Solana.RPC.HTTP.Block where + +import Data.Aeson +import Data.Aeson.Types +import Data.Int +import Data.Map +import Data.Word (Word64) +import GHC.Generics (Generic) +import Network.JsonRpc.TinyClient (JsonRpc (..)) +import Network.Solana.Core.Block +import Network.Solana.Core.Crypto (SolanaPublicKey) +import Network.Solana.Core.Transaction (Transaction) +import Network.Solana.RPC.HTTP.Types + +------------------------------------------------------------------------------------------------ + +-- ** getBlock + +------------------------------------------------------------------------------------------------ + +-- | Returns identity and transaction information about a confirmed block in +-- the ledger, using the given configuration. +-- Returns 'Nothing' if the slot has been skipped or pruned from the ledger. +getBlock' :: (JsonRpc m) => Slot -> ConfigurationObject -> m (Maybe BlockInfo) +getBlock' = do + remote "getBlock" +{-# INLINE getBlock' #-} + +-- | Returns identity and transaction information about a confirmed block in +-- the ledger. Sets @maxSupportedTransactionVersion@ so that blocks +-- containing versioned (v0) transactions can be decoded (without it, such +-- blocks make the node respond with error -32015); as a result, v0 +-- transactions are returned without their address-lookup-table data, so +-- instruction account indices may reference addresses not present in the +-- parsed account keys. +-- Returns 'Nothing' if the slot has been skipped or pruned from the ledger. +getBlock :: (JsonRpc m) => Slot -> m (Maybe BlockInfo) +getBlock slot = getBlock' slot (defaultConfigObject {encoding = Just "json", maxSupportedTransactionVersion = Just 0}) +{-# INLINE getBlock #-} + +-- | Contains identity and transaction information for a block. +data BlockInfo = BlockInfo + { -- | The blockhash of this block. + blockhashBI :: BlockHash, + -- | The blockhash of this block's parent. If the parent is not available due to ledger cleanup, this will return "11111111111111111111111111111111". + previousBlockhashBI :: BlockHash, + -- | The slot index of this block's parent. + parentSlotBI :: Slot, + -- | List of transactions included in the block, each with optional metadata. + transactionsBI :: [TransactionWithMeta], + -- | Estimated production time, as a Unix timestamp (in seconds). 'Nothing' if not available. + blockTimeBI :: Maybe Int64, + -- | The number of blocks beneath this block. + blockHeightBI :: Maybe BlockHeight + } + deriving (Show) + +instance FromJSON BlockInfo where + parseJSON :: Value -> Parser BlockInfo + parseJSON = withObject "BlockInfo" $ \v -> + BlockInfo + <$> v .: "blockhash" + <*> v .: "previousBlockhash" + <*> v .: "parentSlot" + <*> v .: "transactions" + <*> v .: "blockTime" + <*> v .: "blockHeight" + +-- | A transaction and its optional metadata as included in a block. +data TransactionWithMeta = TransactionWithMeta + { -- | Optional metadata for the transaction. + meta :: Maybe Object, + -- | The transaction details. + transaction :: Transaction + } + deriving (Generic, Show, FromJSON) + +------------------------------------------------------------------------------------------------ + +-- ** getBlockCommitment + +------------------------------------------------------------------------------------------------ + +-- | Get the block commitment based on the given block number 'Slot'. +-- Returns a 'BlockCommitment' for the specified block. +getBlockCommitment :: (JsonRpc m) => Slot -> m BlockCommitment +getBlockCommitment = do + remote "getBlockCommitment" +{-# INLINE getBlockCommitment #-} + +-- | Commitment information for a block. +data BlockCommitment = BlockCommitment + { -- | Array logging the amount of cluster stake in lamports that has voted on the block at each depth from 0 to MAX_LOCKOUT_HISTORY + commitmentList :: Maybe [Word64], + -- | Total active stake, in lamports, for the current epoch. + totalStake :: Integer + } + deriving (Show) + +instance FromJSON BlockCommitment where + parseJSON = withObject "BlockCommitment" $ \v -> + BlockCommitment + <$> v .: "commitment" + <*> v .: "totalStake" + +------------------------------------------------------------------------------------------------ + +-- ** getBlockHeight + +------------------------------------------------------------------------------------------------ + +-- | Returns the current block height of the node. +getBlockHeight :: (JsonRpc m) => m BlockHeight +getBlockHeight = do + remote "getBlockHeight" +{-# INLINE getBlockHeight #-} + +------------------------------------------------------------------------------------------------ + +-- ** getBlockProduction + +------------------------------------------------------------------------------------------------ + +-- | Returns recent block production information from the current or previous epoch. +-- Returns 'RPCResponse' 'BlockProduction' with the production statistics. +getBlockProduction' :: (JsonRpc m) => m (RPCResponse BlockProduction) +getBlockProduction' = do + remote "getBlockProduction" +{-# INLINE getBlockProduction' #-} + +-- | Returns recent block production information from the current or previous epoch. +getBlockProduction :: (JsonRpc m) => m BlockProduction +getBlockProduction = value <$> getBlockProduction' +{-# INLINE getBlockProduction #-} + +-- | Per-validator production counts: a two-element array of the number of leader slots and the number of blocks produced. +type ValidatorData = [Word64] + +-- | Mapping from validator identity to its production counts ('ValidatorData'). +type ByIdentity = Map SolanaPublicKey ValidatorData + +-- | Range of slots considered for block production. +data BlockProductionRange = BlockProductionRange + { -- | First slot in the range. + firstSlot :: Slot, + -- | Last slot in the range. + lastSlot :: Slot + } + deriving (Show, Generic, FromJSON) + +-- | Block production statistics mapped by validator identity. +data BlockProduction + = BlockProduction + -- | Mapping from validator identity to number of blocks produced. + ByIdentity + -- | Range of slots considered. + BlockProductionRange + deriving (Generic, Show) + +instance FromJSON BlockProduction where + parseJSON :: Value -> Parser BlockProduction + parseJSON = withObject "BlockProduction" $ \v -> + BlockProduction + <$> v .: "byIdentity" + <*> v .: "range" + +------------------------------------------------------------------------------------------------ + +-- * getBlocks + +------------------------------------------------------------------------------------------------ + +-- | Returns a list of confirmed blocks between two slots (inclusive). +-- The maximum range allowed is 500,000 slots. +getBlocks :: (JsonRpc m) => Slot -> Maybe Slot -> m [Slot] +getBlocks = do + remote "getBlocks" +{-# INLINE getBlocks #-} + +------------------------------------------------------------------------------------------------ + +-- * getBlocksWithLimit + +------------------------------------------------------------------------------------------------ + +-- | Returns a list of confirmed blocks starting from the given slot, up to the specified limit. +getBlocksWithLimit :: (JsonRpc m) => Slot -> Int -> m [Slot] +getBlocksWithLimit = do + remote "getBlocksWithLimit" +{-# INLINE getBlocksWithLimit #-} + +------------------------------------------------------------------------------------------------ + +-- * getBlockTime + +------------------------------------------------------------------------------------------------ + +-- | Returns the estimated production time of a block (as Unix timestamp). +-- This is based on stake-weighted votes and validator-reported timestamps. +-- Returns 'Nothing' if the timestamp is not available for the given slot. +getBlockTime :: (JsonRpc m) => Slot -> m (Maybe Int) +getBlockTime = do + remote "getBlockTime" +{-# INLINE getBlockTime #-} + +------------------------------------------------------------------------------------------------ + +-- * getLatestBlockhash + +------------------------------------------------------------------------------------------------ + +-- | Get the hash and height of the latest block. +-- Returns 'RPCResponse' 'LatestBlockHash' containing the block information. +getLatestBlockhash' :: (JsonRpc m) => m (RPCResponse LatestBlockHash) +getLatestBlockhash' = do + remote "getLatestBlockhash" +{-# INLINE getLatestBlockhash' #-} + +-- | Get the hash and height of the latest block. +getLatestBlockhash :: (JsonRpc m) => m LatestBlockHash +getLatestBlockhash = value <$> getLatestBlockhash' +{-# INLINE getLatestBlockhash #-} + +-- | Get only the blockhash of the latest block. +getTheLatestBlockhash :: (JsonRpc m) => m BlockHash +getTheLatestBlockhash = blockhash <$> getLatestBlockhash +{-# INLINE getTheLatestBlockhash #-} + +-- | Contains the hash and the height of the latest block. +data LatestBlockHash = LatestBlockHash + { -- | Block hash as a base-58 encoded string. + blockhash :: BlockHash, + -- | Last block height at which the blockhash is still considered valid. + lastValidBlockHeight :: BlockHeight + } + deriving (Generic, Show, FromJSON) + +------------------------------------------------------------------------------------------------ + +-- * isBlockhashValid + +------------------------------------------------------------------------------------------------ + +-- | Returns whether a blockhash is still valid. +isBlockhashValid' :: (JsonRpc m) => BlockHash -> m (RPCResponse Bool) +isBlockhashValid' = do + remote "isBlockhashValid" +{-# INLINE isBlockhashValid' #-} + +-- | Returns whether a blockhash is still valid. +isBlockhashValid :: (JsonRpc m) => BlockHash -> m Bool +isBlockhashValid = fmap value . isBlockhashValid' +{-# INLINE isBlockhashValid #-} diff --git a/src/Network/Solana/RPC/HTTP/Chain.hs b/src/Network/Solana/RPC/HTTP/Chain.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/RPC/HTTP/Chain.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Solana.RPC.HTTP.Chain +-- Description : Cluster and node-level RPC methods for Solana. +-- +-- This module provides access to Solana JSON-RPC endpoints related to cluster-wide +-- and node-specific information. +-- +-- These endpoints are especially useful for monitoring, diagnostics, +-- and understanding the state of the cluster from a validator or RPC node's perspective. +module Network.Solana.RPC.HTTP.Chain where + +import Data.Aeson +import Data.Aeson.Types +import Data.List (sort) +import Data.Word +import GHC.Generics (Generic) +import Network.JsonRpc.TinyClient (JsonRpc (..)) +import Network.Solana.Core.Crypto (SolanaPublicKey) +import Network.Solana.RPC.HTTP.Types + +------------------------------------------------------------------------------------------------ + +-- * getClusterNodes + +------------------------------------------------------------------------------------------------ + +-- | Returns information about all the nodes currently participating in the cluster. +getClusterNodes :: (JsonRpc m) => m [ClusterNodes] +getClusterNodes = do + remote "getClusterNodes" +{-# INLINE getClusterNodes #-} + +-- | Contains information about all the nodes participating in the cluster. +data ClusterNodes = ClusterNodes + { -- | The node's public key. + pubkey :: SolanaPublicKey, + -- | Gossip network address for the node. + gossip :: Maybe String, + -- | TPU (Transaction Processing Unit) network address. + tpu :: Maybe String, + -- | JSON-RPC address, if the RPC service is enabled. + rpc :: Maybe String, + -- | Software version of the node, if available. + version :: Maybe String, + -- | Unique identifier of the node's feature set. + featureSet :: Maybe Word32, + -- | Shred version used by the node. + shredVersion :: Maybe Word16 + } + deriving (Show, Generic, FromJSON) + +------------------------------------------------------------------------------------------------ + +-- * getHealth + +------------------------------------------------------------------------------------------------ + +-- | Checks if the node is healthy. +-- +-- A healthy node is within a certain number of slots (defined by @HEALTH_CHECK_SLOT_DISTANCE@, a validator-side constant) +-- of the latest confirmed cluster slot. Returns @"ok"@ if healthy; otherwise, an error is returned. +getHealth :: (JsonRpc m) => m String +getHealth = do + remote "getHealth" +{-# INLINE getHealth #-} + +------------------------------------------------------------------------------------------------ + +-- * getHighestSnapshotSlot + +------------------------------------------------------------------------------------------------ + +-- | Returns the highest full and incremental snapshot slots that the node has generated. +-- +-- This includes the highest full snapshot slot and, if available, the corresponding highest incremental snapshot slot. +getHighestSnapshotSlot :: (JsonRpc m) => m HighestSnapshotSlot +getHighestSnapshotSlot = do + remote "getHighestSnapshotSlot" +{-# INLINE getHighestSnapshotSlot #-} + +-- | Contains the highest slot information that the node has snapshots for. +data HighestSnapshotSlot = HighestSnapshotSlot + { -- | The highest full snapshot slot. + full :: Word64, + -- | The highest incremental snapshot slot, if available. + incremental :: Maybe Word64 + } + deriving (Show, Generic, FromJSON) + +------------------------------------------------------------------------------------------------ + +-- * getIdentity + +------------------------------------------------------------------------------------------------ + +-- | Returns the full 'NodeIdentity' object for the current node. +getIdentity' :: (JsonRpc m) => m NodeIdentity +getIdentity' = do + remote "getIdentity" +{-# INLINE getIdentity' #-} + +-- | Returns the identity public key of the current node. +getIdentity :: (JsonRpc m) => m SolanaPublicKey +getIdentity = identity <$> getIdentity' +{-# INLINE getIdentity #-} + +-- | Identity information for the current node. +newtype NodeIdentity = NodeIdentity + { -- | The node's identity public key. + identity :: SolanaPublicKey + } + deriving (Show, Generic) + deriving anyclass (FromJSON) + +------------------------------------------------------------------------------------------------ + +-- * getRecentPerformanceSamples + +------------------------------------------------------------------------------------------------ + +-- | Returns a list of recent 'PerformanceSample' entries, in reverse slot order. +-- +-- Performance samples are collected every 60 seconds and include metrics such as the number +-- of transactions, slots, and non-vote transactions within each sample window. +-- Optionally takes the number of samples to return (must be ≤ 720). +getRecentPerformanceSamples :: (JsonRpc m) => Maybe Int -> m [PerformanceSample] +getRecentPerformanceSamples = do + remote "getRecentPerformanceSamples" +{-# INLINE getRecentPerformanceSamples #-} + +-- | Performance metrics sampled periodically from the node. +data PerformanceSample = PerformanceSample + { -- | Slot in which the sample was taken. + slot :: Slot, + -- | Number of transactions during the sample period. + numTransactions :: Word64, + -- | Number of slots completed during the sample. + numSlots :: Word64, + -- | Duration of the sampling window, in seconds. + samplePeriodSecs :: Word16, + -- | Number of non-vote transactions during the sample. + numNonVoteTransactions :: Word64 + } + deriving (Generic, Show, FromJSON) + +------------------------------------------------------------------------------------------------ + +-- * getRecentPrioritizationFees + +------------------------------------------------------------------------------------------------ + +-- | Returns recent prioritization fees observed in recent blocks. +-- +-- Optionally takes a list of up to 128 account addresses. If provided, the response estimates +-- the prioritization fee for landing a transaction that locks all listed accounts as writable. +getRecentPrioritizationFees :: (JsonRpc m) => Maybe [SolanaPublicKey] -> m [PrioritizationFee] +getRecentPrioritizationFees = do + remote "getRecentPrioritizationFees" +{-# INLINE getRecentPrioritizationFees #-} + +-- | A prioritization fee sample from a recent block. +data PrioritizationFee = PrioritizationFee + { -- | Slot in which the fee was observed. + pfSlot :: Slot, + -- | Per-compute-unit fee (in micro-lamports). + prioritizationFee :: Word64 + } + deriving (Generic, Show) + +instance FromJSON PrioritizationFee where + parseJSON :: Value -> Parser PrioritizationFee + parseJSON = withObject "PrioritizationFee" $ \v -> + PrioritizationFee + <$> v .: "slot" + <*> v .: "prioritizationFee" + +-- | Nearest-rank percentile over the sorted, nonzero fee samples (e.g. from +-- 'getRecentPrioritizationFees'). Zero samples (slots with no priority fee) +-- are dropped before ranking, so the result reflects only slots that +-- actually paid a priority fee. @p@ is clamped into @[0, 1]@. An empty +-- sample list, or one containing only zeros, returns @0@. +percentilePriorityFee :: Double -> [Word64] -> Word64 +percentilePriorityFee p samples = + case sort (filter (/= 0) samples) of + [] -> 0 + nonzero -> + let n = length nonzero + clampedP = max 0 (min 1 p) + idx = max 0 (ceiling (clampedP * fromIntegral n) - 1) + in nonzero !! idx + +------------------------------------------------------------------------------------------------ + +-- * getVersion + +------------------------------------------------------------------------------------------------ + +-- | Returns the Solana software version and feature set currently running on the node. +getVersion :: (JsonRpc m) => m SolanaVersion +getVersion = do + remote "getVersion" + +-- | Contains information about the software version and feature set identifier of the node. +data SolanaVersion = SolanaVersion + { -- | Software version of 'solana-core'. + solana_core :: String, + -- | Unique identifier of the software's feature set. + feature_set :: Word32 + } + deriving (Generic, Show, Eq) + +instance FromJSON SolanaVersion where + parseJSON :: Value -> Parser SolanaVersion + parseJSON = withObject "SolanaVersion" $ \v -> + SolanaVersion + <$> v .: "solana-core" + <*> v .: "feature-set" diff --git a/src/Network/Solana/RPC/HTTP/Ledger.hs b/src/Network/Solana/RPC/HTTP/Ledger.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/RPC/HTTP/Ledger.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Solana.RPC.HTTP.Ledger +-- Description : Ledger-level Solana RPC methods for querying epoch and slot data. +-- +-- This module provides bindings to Solana JSON-RPC methods related to the ledger, +-- including epoch and slot information, block leader schedules, genesis data, +-- and transaction counts. It is useful for building explorers, monitoring tools, +-- or protocols that depend on precise ledger state and validator schedule tracking. +module Network.Solana.RPC.HTTP.Ledger where + +import Data.Aeson +import Data.Map +import Data.Word +import GHC.Generics +import Network.JsonRpc.TinyClient (JsonRpc (..)) +import Network.Solana.Core.Block +import Network.Solana.Core.Crypto (SolanaPublicKey) +import Network.Solana.RPC.HTTP.Types + +------------------------------------------------------------------------------------------------ + +-- * getEpochInfo + +------------------------------------------------------------------------------------------------ + +-- | Returns information about the current epoch. +-- +-- This includes the current slot, block height, epoch index, and transaction count since genesis. +getEpochInfo :: (JsonRpc m) => m EpochInfo +getEpochInfo = do + remote "getEpochInfo" +{-# INLINE getEpochInfo #-} + +-- | Solana epoch index. +type Epoch = Word64 + +-- | Contains information about the current epoch. +data EpochInfo = EpochInfo + { -- | The current absolute slot. + absoluteSlot :: Slot, + -- | The current block height. + blockHeight :: Word64, + -- | The current epoch index. + epoch :: Epoch, + -- | Slot index relative to the start of the epoch. + slotIndex :: Word64, + -- | Total number of slots in the epoch. + slotsInEpoch :: Word64, + -- | Total number of successful transactions since genesis. + transactionCount :: Maybe Word64 + } + deriving (Show, Generic, FromJSON) + +------------------------------------------------------------------------------------------------ + +-- * getEpochSchedule + +------------------------------------------------------------------------------------------------ + +-- | Returns the epoch scheduling parameters configured in the cluster's genesis configuration. +getEpochSchedule :: (JsonRpc m) => m EpochSchedule +getEpochSchedule = do + remote "getEpochSchedule" +{-# INLINE getEpochSchedule #-} + +-- | Contains epoch schedule information as defined in the cluster's genesis config. +data EpochSchedule = EpochSchedule + { -- | Maximum number of slots per epoch. + slotsPerEpoch :: Word64, + -- | Number of slots before epoch start to compute leader schedule. + leaderScheduleSlotOffset :: Word64, + -- | Whether epochs start small and grow (warmup). + warmup :: Bool, + -- | First normal-length epoch.(log2(slotsPerEpoch) - log2(MINIMUM_SLOTS_PER_EPOCH)) + firstNormalEpoch :: Word64, + -- | First slot of the first normal-length epoch. ( MINIMUM_SLOTS_PER_EPOCH * (2.pow(firstNormalEpoch) - 1)) + firstNormalSlot :: Word64 + } + deriving (Show, Generic, FromJSON) + +------------------------------------------------------------------------------------------------ + +-- * getFirstAvailableBlock + +------------------------------------------------------------------------------------------------ + +-- | Returns the slot of the lowest confirmed block that has not been purged from the ledger. +getFirstAvailableBlock :: (JsonRpc m) => m Slot +getFirstAvailableBlock = do + remote "getFirstAvailableBlock" +{-# INLINE getFirstAvailableBlock #-} + +------------------------------------------------------------------------------------------------ + +-- * getGenesisHash + +------------------------------------------------------------------------------------------------ + +-- | Returns the block hash of the genesis block. +getGenesisHash :: (JsonRpc m) => m BlockHash +getGenesisHash = do + remote "getGenesisHash" +{-# INLINE getGenesisHash #-} + +------------------------------------------------------------------------------------------------ + +-- * getLeaderSchedule + +------------------------------------------------------------------------------------------------ + +-- | Returns the leader schedule mapping validator identities to their leader slots. +-- +-- Fetches the leader schedule for the epoch that contains the specified slot. +-- If no slot is specified, the schedule for the current epoch is returned. +getLeaderSchedule :: (JsonRpc m) => Maybe Slot -> m (Maybe LeaderSchedule) +getLeaderSchedule = do + remote "getLeaderSchedule" +{-# INLINE getLeaderSchedule #-} + +-- | Map from validator identity pubkeys to arrays of slot indices +-- indicating when each validator is expected to produce a block. +type LeaderSchedule = Map SolanaPublicKey [Word64] + +------------------------------------------------------------------------------------------------ + +-- * getMaxRetransmitSlot + +------------------------------------------------------------------------------------------------ + +-- | Returns the highest slot observed by the node from the retransmit stage. +getMaxRetransmitSlot :: (JsonRpc m) => m Slot +getMaxRetransmitSlot = do + remote "getMaxRetransmitSlot" +{-# INLINE getMaxRetransmitSlot #-} + +------------------------------------------------------------------------------------------------ + +-- * getMaxShredInsertSlot + +------------------------------------------------------------------------------------------------ + +-- | Returns the highest slot observed by the node after shred insertion. +getMaxShredInsertSlot :: (JsonRpc m) => m Slot +getMaxShredInsertSlot = do + remote "getMaxShredInsertSlot" +{-# INLINE getMaxShredInsertSlot #-} + +------------------------------------------------------------------------------------------------ + +-- * getSlot + +------------------------------------------------------------------------------------------------ + +-- | Returns the current slot, based on the default or specified commitment level. +getSlot :: (JsonRpc m) => m Slot +getSlot = do + remote "getSlot" + +------------------------------------------------------------------------------------------------ + +-- * getSlotLeader + +------------------------------------------------------------------------------------------------ + +-- | Returns the identity public key of the current slot leader. +getSlotLeader :: (JsonRpc m) => m SolanaPublicKey +getSlotLeader = do + remote "getSlotLeader" + +------------------------------------------------------------------------------------------------ + +-- * getSlotLeaders + +------------------------------------------------------------------------------------------------ + +-- | Returns the list of slot leaders for a given slot range. +-- +-- Takes a starting 'Slot' and a limit (between 1 and 5,000), and returns the validator identities +-- that will produce blocks for the given slots. +getSlotLeaders :: (JsonRpc m) => Slot -> Int -> m [SolanaPublicKey] +getSlotLeaders = do + remote "getSlotLeaders" + +------------------------------------------------------------------------------------------------ + +-- * getTransactionCount + +------------------------------------------------------------------------------------------------ + +-- | Returns the total number of transactions recorded in the ledger. +getTransactionCount :: (JsonRpc m) => m Word64 +getTransactionCount = do + remote "getTransactionCount" + +------------------------------------------------------------------------------------------------ + +-- * minimumLedgerSlot + +------------------------------------------------------------------------------------------------ + +-- | Returns the lowest slot that the node has information about in its ledger. +minimumLedgerSlot :: (JsonRpc m) => m Slot +minimumLedgerSlot = do + remote "minimumLedgerSlot" diff --git a/src/Network/Solana/RPC/HTTP/Token.hs b/src/Network/Solana/RPC/HTTP/Token.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/RPC/HTTP/Token.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Solana.RPC.HTTP.Token +-- Description : Solana RPC methods for interacting with SPL Token accounts. +-- +-- This module provides access to Solana JSON-RPC methods related to SPL Token accounts. +-- It includes queries for fetching token balances, owned accounts, delegated accounts, +-- largest token holders, and token supply information. +-- +-- It is useful for building wallets, explorers, or token dashboards that interact +-- with SPL-compliant tokens deployed on the Solana blockchain. +module Network.Solana.RPC.HTTP.Token where + +import Data.Aeson +import Data.Word +import GHC.Generics (Generic) +import Network.JsonRpc.TinyClient (JsonRpc (..)) +import Network.Solana.Core.Account (Account) +import Network.Solana.Core.Crypto (SolanaPublicKey) +import Network.Solana.RPC.HTTP.Types + +------------------------------------------------------------------------------------------------ + +-- * getTokenAccountBalance + +------------------------------------------------------------------------------------------------ + +-- | Returns the token balance of an SPL Token account. +-- Returns 'RPCResponse' 'AmountObject' with detailed balance information. +getTokenAccountBalance' :: (JsonRpc m) => SolanaPublicKey -> m (RPCResponse AmountObject) +getTokenAccountBalance' = do + remote "getTokenAccountBalance" + +-- | Returns the token balance of an SPL Token account. +getTokenAccountBalance :: (JsonRpc m) => SolanaPublicKey -> m AmountObject +getTokenAccountBalance = fmap value . getTokenAccountBalance' + +-- | Contains SPL token balance details. +data AmountObject = AmountObject + { -- | The raw balance without decimals, a string representation of 'Word64'. + amount :: String, + -- | Number of base 10 digits to the right of the decimal place. + decimals :: Word8, + -- | The balance using mint-prescribed decimals (deprecated). + uiAmount :: Maybe Double, + -- | The balance as a string, using mint-prescribed decimals. + uiAmountString :: String + } + deriving (Generic, Show, Eq) + deriving anyclass (FromJSON) + +------------------------------------------------------------------------------------------------ + +-- * getTokenAccountsByDelegate + +------------------------------------------------------------------------------------------------ + +-- | Returns all SPL Token accounts delegated to the provided delegate address, using the given configuration. +getTokenAccountsByDelegate' :: (JsonRpc m) => SolanaPublicKey -> SolanaPubKeyWithPurpose -> ConfigurationObject -> m (RPCResponse [Account]) +getTokenAccountsByDelegate' = do + remote "getTokenAccountsByDelegate" +{-# INLINE getTokenAccountsByDelegate' #-} + +-- | Returns all SPL Token accounts delegated to the provided delegate +-- address, requesting base64 encoding. +getTokenAccountsByDelegate :: (JsonRpc m) => SolanaPublicKey -> SolanaPubKeyWithPurpose -> m [Account] +getTokenAccountsByDelegate pk pkwv = value <$> getTokenAccountsByDelegate' pk pkwv cfgJustEncodingBase64 +{-# INLINE getTokenAccountsByDelegate #-} + +------------------------------------------------------------------------------------------------ + +-- * getTokenAccountsByOwner + +------------------------------------------------------------------------------------------------ + +-- | Specifies either a mint or a program to filter token accounts. +data SolanaPubKeyWithPurpose = Mint SolanaPublicKey | Program SolanaPublicKey + deriving (Generic) + +instance ToJSON SolanaPubKeyWithPurpose where + toJSON (Mint key) = object ["mint" .= key] + toJSON (Program key) = object ["programId" .= key] + +-- | Returns all SPL Token accounts owned by the specified wallet. +getTokenAccountsByOwner' :: (JsonRpc m) => SolanaPublicKey -> SolanaPubKeyWithPurpose -> ConfigurationObject -> m (RPCResponse [Account]) +getTokenAccountsByOwner' = do + remote "getTokenAccountsByOwner" +{-# INLINE getTokenAccountsByOwner' #-} + +-- | Returns all SPL Token accounts owned by the specified wallet. +getTokenAccountsByOwner :: (JsonRpc m) => SolanaPublicKey -> SolanaPubKeyWithPurpose -> m [Account] +getTokenAccountsByOwner pk pkwv = value <$> getTokenAccountsByOwner' pk pkwv cfgJustEncodingBase64 +{-# INLINE getTokenAccountsByOwner #-} + +-- | Returns all SPL Token accounts for the specified owner and mint address. +getTokenAccountsByOwnerAndMint :: (JsonRpc m) => SolanaPublicKey -> SolanaPublicKey -> m [Account] +getTokenAccountsByOwnerAndMint pk pkwv = value <$> getTokenAccountsByOwner' pk (Mint pkwv) cfgJustEncodingBase64 +{-# INLINE getTokenAccountsByOwnerAndMint #-} + +-- | Returns all SPL Token accounts for the specified owner and program ID. +getTokenAccountsByOwnerAndProgram :: (JsonRpc m) => SolanaPublicKey -> SolanaPublicKey -> m [Account] +getTokenAccountsByOwnerAndProgram pk pkwv = value <$> getTokenAccountsByOwner' pk (Program pkwv) cfgJustEncodingBase64 +{-# INLINE getTokenAccountsByOwnerAndProgram #-} + +------------------------------------------------------------------------------------------------ + +-- * getTokenLargestAccounts + +------------------------------------------------------------------------------------------------ + +-- | Returns the largest accounts for a given SPL Token mint, sorted by balance. +-- Returns 'RPCResponse' @['AmountObjectWithAddr']@. +getTokenLargestAccounts' :: (JsonRpc m) => SolanaPublicKey -> m (RPCResponse [AmountObjectWithAddr]) +getTokenLargestAccounts' = do + remote "getTokenLargestAccounts" + +-- | Returns the largest accounts for a given SPL Token mint, sorted by balance. +getTokenLargestAccounts :: (JsonRpc m) => SolanaPublicKey -> m [AmountObjectWithAddr] +getTokenLargestAccounts = fmap value . getTokenLargestAccounts' + +-- | Contains address and balance information for an SPL Token account. +data AmountObjectWithAddr = AmountObjectWithAddr + { -- | The account address. + address' :: SolanaPublicKey, + -- | The raw balance without decimals, a string representation of 'Word64'. + amount' :: String, + -- | Number of base 10 digits to the right of the decimal place. + decimals' :: Word8, + -- | The balance using mint-prescribed decimals (deprecated). + uiAmount' :: Maybe Double, + -- | The balance as a string, using mint-prescribed decimals. + uiAmountString' :: String + } + deriving (Generic, Show) + +instance FromJSON AmountObjectWithAddr where + parseJSON = withObject "AmountObjectWithAddr" $ \v -> + AmountObjectWithAddr + <$> v .: "address" + <*> v .: "amount" + <*> v .: "decimals" + <*> v .: "uiAmount" + <*> v .: "uiAmountString" + +------------------------------------------------------------------------------------------------ + +-- * getTokenSupply + +------------------------------------------------------------------------------------------------ + +-- | Returns the total supply of an SPL Token. +-- Returns 'RPCResponse' 'AmountObject' with the supply balance. +getTokenSupply' :: (JsonRpc m) => SolanaPublicKey -> m (RPCResponse AmountObject) +getTokenSupply' = do + remote "getTokenSupply" + +-- | Returns the total supply of an SPL Token. +getTokenSupply :: (JsonRpc m) => SolanaPublicKey -> m AmountObject +getTokenSupply = fmap value . getTokenSupply' diff --git a/src/Network/Solana/RPC/HTTP/Tokenomics.hs b/src/Network/Solana/RPC/HTTP/Tokenomics.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/RPC/HTTP/Tokenomics.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Solana.RPC.HTTP.Tokenomics +-- Description : Solana RPC methods for querying inflation, staking, supply, and vote account data. +-- +-- This module exposes Solana JSON-RPC methods for interacting with protocol-level +-- tokenomics: inflation schedules, rewards, token supply, staking parameters, and +-- validator vote accounts. +-- +-- Useful for dashboards, analytics tools, staking services, or indexers. +module Network.Solana.RPC.HTTP.Tokenomics where + +import Data.Aeson +import Data.Aeson.Types +import Data.Int (Int64) +import Data.Word +import GHC.Generics +import Network.JsonRpc.TinyClient (JsonRpc (..)) +import Network.Solana.Core.Account (Lamport) +import Network.Solana.Core.Crypto (SolanaPublicKey) +import Network.Solana.RPC.HTTP.Types + +------------------------------------------------------------------------------------------------ + +-- * getInflationGovernor + +------------------------------------------------------------------------------------------------ + +-- | Returns the current inflation governor parameters. +-- +-- These parameters define how inflation is distributed and how it changes over time. +getInflationGovernor :: (JsonRpc m) => m InflationGovernor +getInflationGovernor = do + remote "getInflationGovernor" +{-# INLINE getInflationGovernor #-} + +-- | Parameters defining the inflation configuration. +data InflationGovernor = InflationGovernor + { -- | Percentage of inflation allocated to the foundation. + foundation :: Double, + -- | Duration of the foundation pool inflation (in years). + foundationTerm :: Double, + -- | Initial inflation rate at genesis (percentage). + initial :: Double, + -- | Rate per year at which inflation is lowered. (Rate reduction is derived using the target slot time in genesis config) + taper :: Double, + -- | Terminal inflation rate (percentage). + terminal :: Double + } + deriving (Show, Generic, FromJSON) + +------------------------------------------------------------------------------------------------ + +-- * getInflationRate + +------------------------------------------------------------------------------------------------ + +-- | Returns the inflation rate values for the current epoch. +getInflationRate :: (JsonRpc m) => m InflationRate +getInflationRate = do + remote "getInflationRate" +{-# INLINE getInflationRate #-} + +-- | Inflation breakdown for the current epoch. +data InflationRate = InflationRate + { -- | Total inflation rate (percentage). + totalInflation :: Double, + -- | Portion allocated to validators. + validatorInflation :: Double, + -- | Portion allocated to the foundation. + foundationInflation :: Double, + -- | Epoch index for which these values apply. + epochInflation :: Int64 + } + deriving (Show) + +instance FromJSON InflationRate where + parseJSON :: Value -> Parser InflationRate + parseJSON = withObject "InflationRate" $ \v -> + InflationRate + <$> v .: "total" + <*> v .: "validator" + <*> v .: "foundation" + <*> v .: "epoch" + +------------------------------------------------------------------------------------------------ + +-- * getInflationReward + +------------------------------------------------------------------------------------------------ + +-- | Returns the inflation reward for the specified accounts during an epoch. +-- +-- Takes a list of public keys and returns a list of optional rewards. +-- Entries may be 'Nothing' if the reward could not be determined for the given account. +getInflationReward :: (JsonRpc m) => [SolanaPublicKey] -> m [Maybe InflationReward] +getInflationReward = do + remote "getInflationReward" +{-# INLINE getInflationReward #-} + +-- | Contains the inflation reward information for a given account. +data InflationReward = InflationReward + { -- | Epoch in which the reward was issued. + epochReward :: Word64, + -- | Slot in which the reward became effective. + effectiveSlot :: Slot, + -- | Amount of reward, in lamports. + amountReward :: Lamport, + -- | Account balance after the reward was applied. + postBalance :: Lamport, + -- | Vote account commission when the reward was credited. + commissionIR :: Maybe Word8 + } + deriving (Show, Generic) + +instance FromJSON InflationReward where + parseJSON :: Value -> Parser InflationReward + parseJSON = withObject "InflationReward" $ \v -> + InflationReward + <$> v .: "epoch" + <*> v .: "effectiveSlot" + <*> v .: "amount" + <*> v .: "postBalance" + <*> v .: "commission" + +------------------------------------------------------------------------------------------------ + +-- * getMinimumBalanceForRentExemption + +------------------------------------------------------------------------------------------------ + +-- | Returns the minimum lamport balance required for a rent-exempt account. +-- +-- Takes the account's data size in bytes and returns the required balance. +getMinimumBalanceForRentExemption :: (JsonRpc m) => Int -> m Lamport +getMinimumBalanceForRentExemption = do + remote "getMinimumBalanceForRentExemption" +{-# INLINE getMinimumBalanceForRentExemption #-} + +------------------------------------------------------------------------------------------------ + +-- * getStakeMinimumDelegation + +------------------------------------------------------------------------------------------------ + +-- | Returns the minimum delegation amount required to stake. +-- Returns @RPCResponse Lamport@ with value field set to @Lamport@. +getStakeMinimumDelegation' :: (JsonRpc m) => m (RPCResponse Lamport) +getStakeMinimumDelegation' = do + remote "getStakeMinimumDelegation" +{-# INLINE getStakeMinimumDelegation' #-} + +-- | Returns the minimum amount (in lamports) required for stake delegation. +getStakeMinimumDelegation :: (JsonRpc m) => m Lamport +getStakeMinimumDelegation = value <$> getStakeMinimumDelegation' +{-# INLINE getStakeMinimumDelegation #-} + +------------------------------------------------------------------------------------------------ + +-- * getSupply + +------------------------------------------------------------------------------------------------ + +-- | Returns the current token supply information. +-- Returns @RPCResponse SolanaSupply@ with value field set to @SolanaSupply@. +getSupply' :: (JsonRpc m) => m (RPCResponse SolanaSupply) +getSupply' = do + remote "getSupply" + +-- | Returns the current token supply information. +getSupply :: (JsonRpc m) => m SolanaSupply +getSupply = value <$> getSupply' + +-- | Contains information about the total, circulating, and non-circulating token supply. +data SolanaSupply = SolanaSupply + { -- | Total supply in lamports. + total :: Lamport, + -- | Circulating supply in lamports. + circulating :: Lamport, + -- | Non-circulating supply in lamports. + nonCirculating :: Lamport, + -- | Accounts holding non-circulating tokens. + nonCirculatingAccounts :: [SolanaPublicKey] + } + deriving (Generic, Show, Eq) + deriving anyclass (FromJSON) + +------------------------------------------------------------------------------------------------ + +-- * getVoteAccounts + +------------------------------------------------------------------------------------------------ + +-- | Returns vote account information for all validators in the current bank. +-- +-- Includes both current and delinquent vote accounts. +getVoteAccounts :: (JsonRpc m) => m VoteAccounts +getVoteAccounts = do + remote "getVoteAccounts" + +-- | Lists current and delinquent vote accounts. +data VoteAccounts = VoteAccounts + { -- | Currently active vote accounts. + current :: [VoteAccountsResult], + -- | Delinquent vote accounts. + delinquent :: [VoteAccountsResult] + } + deriving (Generic, Show, FromJSON) + +-- | Information about a vote account. +data VoteAccountsResult = VoteAccountsResult + { -- | Address of the vote account. + votePubkey :: SolanaPublicKey, + -- | Identity of the validator node. + nodePubkey :: SolanaPublicKey, + -- | Stake delegated to this vote account (active in this epoch). + activatedStake :: Word64, + -- | Whether the vote account is active this epoch. + epochVoteAccount :: Bool, + -- | Commission percentage charged by the validator (0–100). + commission :: Int, + -- | Most recent slot voted on. + lastVote :: Slot, + -- | Historical epoch credits: [epoch, credits, previousCredits]. + epochCredits :: [[Word64]], + -- | Current root slot for this vote account. + rootSlot :: Slot + } + deriving (Generic, Show, FromJSON) diff --git a/src/Network/Solana/RPC/HTTP/Transaction.hs b/src/Network/Solana/RPC/HTTP/Transaction.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/RPC/HTTP/Transaction.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Solana.RPC.HTTP.Transaction +-- Description : Solana RPC methods for submitting, inspecting, and simulating transactions. +-- +-- This module provides Solana JSON-RPC bindings related to transaction lifecycle operations: +-- fee estimation, transaction broadcasting, simulation, airdrops (on devnet), and retrieving +-- metadata for finalized transactions. +-- +-- These endpoints are essential for any client application that signs and sends transactions. +module Network.Solana.RPC.HTTP.Transaction where + +import Data.Aeson +import Data.Int (Int64) +import GHC.Generics (Generic) +import Network.JsonRpc.TinyClient (JsonRpc (..)) +import Network.Solana.Core.Account (Lamport) +import Network.Solana.Core.Crypto (SolanaPublicKey, SolanaSignature) +import Network.Solana.Core.Transaction +import Network.Solana.RPC.HTTP.Types + +------------------------------------------------------------------------------------------------ + +-- * getFeeForMessage + +------------------------------------------------------------------------------------------------ + +-- | Returns the fee the network will charge for a particular message (base64-encoded). +-- Returns 'RPCResponse' ('Maybe' 'Int') where the value is the fee in lamports, or 'Nothing' if the fee couldn't be calculated. +getFeeForMessage' :: (JsonRpc m) => String -> m (RPCResponse (Maybe Int)) +getFeeForMessage' = do + remote "getFeeForMessage" +{-# INLINE getFeeForMessage' #-} + +-- | Returns the fee the network will charge for a particular message (base64-encoded). +-- Returns 'Maybe Int' fee in lamports. +getFeeForMessage :: (JsonRpc m) => String -> m (Maybe Int) +getFeeForMessage = fmap value . getFeeForMessage' +{-# INLINE getFeeForMessage #-} + +------------------------------------------------------------------------------------------------ + +-- * getTransaction + +------------------------------------------------------------------------------------------------ + +-- | Returns metadata and content for a confirmed transaction identified by +-- its signature, using the given configuration. +-- Returns 'Nothing' if the signature is unknown or has expired. +getTransaction' :: (JsonRpc m) => SolanaSignature -> ConfigurationObject -> m (Maybe TransactionResult) +getTransaction' = do + remote "getTransaction" +{-# INLINE getTransaction' #-} + +-- | Returns metadata and content for a confirmed transaction identified by +-- its signature. Sets @maxSupportedTransactionVersion@ so that versioned +-- (v0) transactions can be decoded (without it, the node responds with +-- error -32015); as a result, v0 transactions are returned without their +-- address-lookup-table data, so instruction account indices may reference +-- addresses not present in the parsed account keys. +-- Returns 'Nothing' if the signature is unknown or has expired. +getTransaction :: (JsonRpc m) => SolanaSignature -> m (Maybe TransactionResult) +getTransaction sig = getTransaction' sig (defaultConfigObject {encoding = Just "json", maxSupportedTransactionVersion = Just 0}) +{-# INLINE getTransaction #-} + +-- | Contains metadata and transaction information returned by 'getTransaction'. +data TransactionResult = TransactionResult + { -- | The slot this transaction was processed in. + slotTx :: Slot, + -- | Estimated production time, as Unix timestamp (seconds since the Unix epoch) when the transaction was processed. + blockTimeTx :: Maybe Int64, + -- | Optional transaction metadata. + metaTx :: Maybe Object, + -- | The transaction content. + transactionTx :: Transaction + } + deriving (Generic, Show) + +instance FromJSON TransactionResult where + parseJSON = withObject "TransactionResult" $ \v -> + TransactionResult + <$> v .: "slot" + <*> v .: "blockTime" + <*> v .: "meta" + <*> v .: "transaction" + +------------------------------------------------------------------------------------------------ + +-- * requestAirdrop + +------------------------------------------------------------------------------------------------ + +-- | Requests an airdrop of the specified number of lamports to the given address. +requestAirdrop :: (JsonRpc m) => SolanaPublicKey -> Lamport -> m SolanaSignature +requestAirdrop = do + remote "requestAirdrop" +{-# INLINE requestAirdrop #-} + +------------------------------------------------------------------------------------------------ + +-- * sendTransaction + +------------------------------------------------------------------------------------------------ + +-- | Default configuration used for sending transactions. Leaves preflight +-- checks and retry behavior at the node's own defaults; callers who want +-- fire-and-forget behavior (no preflight simulation, no rebroadcast) can use +-- 'sendTransaction'' with an explicit configuration instead. +defaultRpcSendTransactionConfig :: ConfigurationObject +defaultRpcSendTransactionConfig = + defaultConfigObject + { encoding = Just "base64" + } + +-- | Sends a base64-encoded transaction to the cluster using the default configuration. +sendTransaction :: (JsonRpc m) => String -> m SolanaSignature +sendTransaction tx = sendTransaction' tx defaultRpcSendTransactionConfig +{-# INLINE sendTransaction #-} + +-- | Sends a base64-encoded transaction to the cluster with the specified configuration. +sendTransaction' :: (JsonRpc m) => String -> ConfigurationObject -> m SolanaSignature +sendTransaction' = do + remote "sendTransaction" +{-# INLINE sendTransaction' #-} + +------------------------------------------------------------------------------------------------ + +-- * simulateTransaction + +------------------------------------------------------------------------------------------------ + +-- | Simulates a base64-encoded transaction with the given configuration. +simulateTransaction' :: (JsonRpc m) => String -> ConfigurationObject -> m Object +simulateTransaction' = do + remote "simulateTransaction" +{-# INLINE simulateTransaction' #-} + +-- | Simulates a base64-encoded transaction using a basic configuration with base64 encoding. +simulateTransaction :: (JsonRpc m) => String -> m Object +simulateTransaction tx = simulateTransaction' tx cfgJustEncodingBase64 +{-# INLINE simulateTransaction #-} diff --git a/src/Network/Solana/RPC/HTTP/Types.hs b/src/Network/Solana/RPC/HTTP/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/RPC/HTTP/Types.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Solana.RPC.HTTP.Types +-- Description : Common RPC types used across Solana HTTP JSON-RPC endpoints. +-- +-- This module defines shared types used in Solana RPC responses and configuration payloads. +-- It includes generic RPC response envelopes, context metadata, and configuration options +-- for request customization. +-- +-- These types are reused across many Solana JSON-RPC methods and should be imported +-- wherever Solana RPC requests or responses are constructed or parsed. +module Network.Solana.RPC.HTTP.Types where + +import Data.Aeson.Types +import Data.Text +import Data.Word +import GHC.Generics + +------------------------------------------------------------------------------------------------ + +-- * RPCResponse + +------------------------------------------------------------------------------------------------ + +-- | Alias for a Solana slot number. +type Slot = Word64 + +-- | Contains contextual information returned with most Solana RPC responses. +-- +-- Includes API version and the slot at which the response is valid. +data Context = Context + { -- | API version string returned by the cluster (e.g. @"1.17.0"@). + apiVersion :: Text, + -- | The slot at which the data in the response is valid. + contextSlot :: Slot + } + deriving (Show, Generic) + +instance FromJSON Context where + parseJSON :: Value -> Parser Context + parseJSON = withObject "Context" $ \v -> + Context + <$> v .: "apiVersion" + <*> v .: "slot" + +-- | Generic wrapper for Solana RPC responses that include a context and a value. +-- +-- Many Solana RPC methods return a response shaped like: +-- +-- > { "context": { ... }, "value": } +data RPCResponse a = RPCResponse + { -- | Metadata about the cluster state at the time of the response. + context :: Context, + -- | The actual value returned by the RPC method. + value :: a + } + deriving (Show) + +instance (FromJSON a) => FromJSON (RPCResponse a) where + parseJSON :: (FromJSON a) => Value -> Parser (RPCResponse a) + parseJSON = withObject "RPCResponse" $ \v -> + RPCResponse + <$> v .: "context" + <*> v .: "value" + +------------------------------------------------------------------------------------------------ + +-- * ConfigurationObject + +------------------------------------------------------------------------------------------------ + +-- | Configuration options used to customize Solana RPC requests. +-- +-- Many RPC methods accept a configuration object to control encoding, +-- commitment level, preflight behavior, and more. +data ConfigurationObject = ConfigurationObject + { -- | Optional commitment level (e.g. @"finalized"@, @"confirmed"@). + commitment :: Maybe String, + -- | Desired encoding for returned data (e.g. @"base58"@, @"base64"@). + encoding :: Maybe String, + -- | Optional partial data slice configuration. + dataSlice :: Maybe Object, + -- | Whether to skip preflight checks (use with caution). + skipPreflight :: Maybe Bool, + -- | Commitment level used during preflight simulation. + preflightCommitment :: Maybe String, + -- | Maximum number of retry attempts for transaction submission. + maxRetries :: Maybe Int, + -- | Minimum slot that the RPC response must be based on. + minContextSlot :: Maybe Int, + -- | Whether to search older confirmed transaction history. + searchTransactionHistory :: Maybe Bool, + -- | The maximum transaction version to return in responses. Required to + -- fetch blocks or transactions containing versioned (v0) transactions; + -- omitting it causes the RPC to reject them with error -32015. + maxSupportedTransactionVersion :: Maybe Int + } + deriving (Generic, Show) + +instance ToJSON ConfigurationObject where + toJSON :: ConfigurationObject -> Value + toJSON = genericToJSON defaultOptions {omitNothingFields = True} + +-- | A default configuration object with all fields set to 'Nothing'. +-- +-- Use this as a base and override fields selectively. +defaultConfigObject :: ConfigurationObject +defaultConfigObject = + ConfigurationObject + { commitment = Nothing, + encoding = Nothing, + dataSlice = Nothing, + skipPreflight = Nothing, + preflightCommitment = Nothing, + maxRetries = Nothing, + minContextSlot = Nothing, + searchTransactionHistory = Nothing, + maxSupportedTransactionVersion = Nothing + } + +-- | A basic configuration object that only sets the encoding to @"base64"@. +-- +-- Useful for methods that require base64-encoded input or output. +cfgJustEncodingBase64 :: ConfigurationObject +cfgJustEncodingBase64 = + defaultConfigObject + { encoding = Just "base64" + } diff --git a/src/Network/Solana/RPC/WebSocket.hs b/src/Network/Solana/RPC/WebSocket.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/RPC/WebSocket.hs @@ -0,0 +1,332 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Solana.RPC.WebSocket +-- Description : Solana PubSub (WebSocket) subscriptions and push-based confirmation. +-- +-- Solana nodes expose a PubSub endpoint alongside the JSON-RPC one (by +-- convention port @8900@ next to the RPC port @8899@; @wss://@ on hosted +-- clusters). Instead of polling for a transaction's status, a client +-- subscribes once and is pushed a notification the moment the signature +-- reaches the requested commitment. +-- +-- This module is transport-agnostic on purpose: it builds the exact bytes to +-- send, parses the bytes received, and drives the confirmation handshake over +-- a 'WsTransport' that the caller supplies. The SDK therefore needs no +-- WebSocket dependency of its own, and the same code works against plain +-- @ws://@ and TLS @wss://@ endpoints. +-- +-- Wiring it to the @websockets@ package takes a few lines: +-- +-- > import Network.WebSockets qualified as WS +-- > +-- > WS.runClient "127.0.0.1" 8900 "/" $ \conn -> do +-- > let transport = WsTransport (WS.sendTextData conn) (WS.receiveData conn) +-- > result <- awaitSignature transport (RequestId 1) (Just "confirmed") 30 signature +-- > print result +-- +-- For @wss://@ endpoints, use @wuss@'s @runSecureClient@ in place of +-- @runClient@; nothing else changes. +module Network.Solana.RPC.WebSocket + ( -- * Identifiers + RequestId (..), + SubscriptionId (..), + + -- * Requests + signatureSubscribeRequest, + accountSubscribeRequest, + signatureUnsubscribeRequest, + accountUnsubscribeRequest, + + -- * Incoming messages + WsMessage (..), + SignatureNotification (..), + AccountNotification (..), + parseWsMessage, + + -- * Transport + WsTransport (..), + + -- * Confirmation + awaitSignature, + ) +where + +import Data.Aeson +import Data.Aeson.Encoding qualified as E +import Data.Aeson.Types (Parser, parseEither) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BL +import Data.Text (Text) +import Data.Maybe (fromMaybe, isNothing) +import Data.Text qualified as Text +import Data.Word (Word64) +import Network.Solana.Core.Account (AccountInfo) +import Network.Solana.Core.Crypto (SolanaPublicKey, SolanaSignature) +import Network.Solana.RPC.HTTP.Types (Slot) +import System.Timeout (timeout) + +------------------------------------------------------------------------------------------------ + +-- * Identifiers + +------------------------------------------------------------------------------------------------ + +-- | A client-supplied JSON-RPC request id. The node echoes it in the +-- subscription acknowledgement, which is how a reply is matched to its +-- request. +newtype RequestId = RequestId Word64 + deriving stock (Eq, Ord, Show) + deriving newtype (FromJSON, ToJSON) + +-- | A server-assigned subscription id, returned by a @*Subscribe@ call and +-- carried by every notification belonging to that subscription. Pass it to +-- the matching @*Unsubscribe@ request to cancel early. +newtype SubscriptionId = SubscriptionId Word64 + deriving stock (Eq, Ord, Show) + deriving newtype (FromJSON, ToJSON) + +------------------------------------------------------------------------------------------------ + +-- * Requests + +------------------------------------------------------------------------------------------------ + +-- | Encodes a JSON-RPC request with its fields in the documented order. +encodeRequest :: RequestId -> Text -> E.Encoding -> BS.ByteString +encodeRequest (RequestId i) method params = + BL.toStrict . E.encodingToLazyByteString . E.pairs $ + E.pair "jsonrpc" (E.text "2.0") + <> E.pair "id" (E.word64 i) + <> E.pair "method" (E.text method) + <> E.pair "params" params + +-- | Optional @commitment@ field: omitted entirely when unset, in which case +-- the node applies its default (@finalized@). +commitmentField :: Maybe String -> E.Series +commitmentField = foldMap (E.pair "commitment" . E.string) + +-- | A @signatureSubscribe@ request for the given signature. +-- +-- The subscription ends by itself once the signature reaches the requested +-- commitment, so a successful wait needs no unsubscribe. When the last +-- argument is 'True', the node may additionally send an early +-- @receivedSignature@ notification (see 'snReceived'). +signatureSubscribeRequest :: RequestId -> SolanaSignature -> Maybe String -> Bool -> BS.ByteString +signatureSubscribeRequest reqId sig mCommitment enableReceived = + encodeRequest reqId "signatureSubscribe" $ + E.list + id + [ E.string (show sig), + E.pairs (commitmentField mCommitment <> E.pair "enableReceivedNotification" (E.bool enableReceived)) + ] + +-- | An @accountSubscribe@ request for the given account. +-- +-- Account data is requested @base64@-encoded, matching +-- 'Network.Solana.RPC.HTTP.Account.getAccountInfo', so every state decoder in +-- this library applies unchanged to 'anAccount'. +accountSubscribeRequest :: RequestId -> SolanaPublicKey -> Maybe String -> BS.ByteString +accountSubscribeRequest reqId pk mCommitment = + encodeRequest reqId "accountSubscribe" $ + E.list + id + [ E.string (show pk), + E.pairs (commitmentField mCommitment <> E.pair "encoding" (E.string "base64")) + ] + +-- | A @signatureUnsubscribe@ request cancelling the given subscription. +signatureUnsubscribeRequest :: RequestId -> SubscriptionId -> BS.ByteString +signatureUnsubscribeRequest reqId (SubscriptionId s) = + encodeRequest reqId "signatureUnsubscribe" (E.list id [E.word64 s]) + +-- | An @accountUnsubscribe@ request cancelling the given subscription. +accountUnsubscribeRequest :: RequestId -> SubscriptionId -> BS.ByteString +accountUnsubscribeRequest reqId (SubscriptionId s) = + encodeRequest reqId "accountUnsubscribe" (E.list id [E.word64 s]) + +------------------------------------------------------------------------------------------------ + +-- * Incoming messages + +------------------------------------------------------------------------------------------------ + +-- | The status of a subscribed signature. +data SignatureNotification = SignatureNotification + { -- | The slot the notification is valid for. + snSlot :: Slot, + -- | 'Nothing' when the transaction succeeded at the subscribed + -- commitment; the node's @TransactionError@ otherwise. + snErr :: Maybe Value, + -- | 'True' for the early @receivedSignature@ notification, which reports + -- that the node has seen the transaction but says nothing about whether + -- it succeeded. Such a notification is not terminal: the subscription + -- stays open until the signature reaches the requested commitment. + snReceived :: Bool + } + deriving (Eq, Show) + +-- | A subscribed account's state after a change. +data AccountNotification = AccountNotification + { -- | The slot the notification is valid for. + anSlot :: Slot, + -- | The account as of that slot, shaped exactly like a @getAccountInfo@ + -- value. + anAccount :: AccountInfo + } + deriving (Eq, Show) + +-- | A message received from a Solana PubSub endpoint. +data WsMessage + = -- | A @*Subscribe@ request succeeded, yielding a subscription id. + SubscribeAck RequestId SubscriptionId + | -- | An @*Unsubscribe@ request completed. + UnsubscribeAck RequestId Bool + | -- | A @signatureNotification@ for an active subscription. + SignatureNotice SubscriptionId SignatureNotification + | -- | An @accountNotification@ for an active subscription. + AccountNotice SubscriptionId AccountNotification + | -- | A JSON-RPC error, with its code and message. The request id is + -- 'Nothing' when the node could not attribute the error to a request. + WsErrorMessage (Maybe RequestId) Int String + deriving (Eq, Show) + +-- | Parses one PubSub frame. +-- +-- Note that PubSub notifications carry a @context@ object holding only a +-- @slot@ -- unlike the HTTP RPC responses modelled by +-- 'Network.Solana.RPC.HTTP.Types.Context', they omit @apiVersion@ -- so they +-- are parsed here rather than through @RPCResponse@. +parseWsMessage :: BS.ByteString -> Either String WsMessage +parseWsMessage raw = eitherDecodeStrict' raw >>= parseEither wsMessageParser + +wsMessageParser :: Value -> Parser WsMessage +wsMessageParser = withObject "WsMessage" $ \o -> do + mMethod <- o .:? "method" + case mMethod :: Maybe Text of + Just "signatureNotification" -> notice o SignatureNotice signatureNotificationParser + Just "accountNotification" -> notice o AccountNotice accountNotificationParser + Just other -> fail ("unsupported notification method: " <> Text.unpack other) + Nothing -> do + mError <- o .:? "error" + case mError of + Just err -> + WsErrorMessage + <$> o .:? "id" + <*> err .: "code" + <*> err .: "message" + Nothing -> do + reqId <- o .: "id" + result <- o .: "result" + case result of + Bool ok -> pure (UnsubscribeAck reqId ok) + Number _ -> SubscribeAck reqId . SubscriptionId <$> parseJSON result + _ -> fail "result is neither a subscription id nor an unsubscribe flag" + where + notice o build parser = do + params <- o .: "params" + sub <- params .: "subscription" + result <- params .: "result" + build sub <$> parser result + +-- | Both notification kinds wrap their payload in @{context: {slot}, value}@. +withNotificationContext :: (Slot -> Value -> Parser a) -> Value -> Parser a +withNotificationContext build = withObject "notification result" $ \result -> do + ctx <- result .: "context" + slot <- ctx .: "slot" + value <- result .: "value" + build slot value + +signatureNotificationParser :: Value -> Parser SignatureNotification +signatureNotificationParser = withNotificationContext $ \slot value -> + case value of + String "receivedSignature" -> pure (SignatureNotification slot Nothing True) + _ -> flip (withObject "signature notification value") value $ \v -> do + err <- v .:? "err" + pure (SignatureNotification slot err False) + +accountNotificationParser :: Value -> Parser AccountNotification +accountNotificationParser = withNotificationContext $ \slot value -> + AccountNotification slot <$> parseJSON value + +------------------------------------------------------------------------------------------------ + +-- * Transport and confirmation + +------------------------------------------------------------------------------------------------ + +-- | A minimal bidirectional message transport: everything this module needs +-- from a WebSocket connection. +-- +-- Supplying this rather than a concrete connection type is what keeps the +-- library free of a WebSocket dependency (see the module header for the +-- @websockets@ wiring), and lets the confirmation handshake be tested without +-- a network. +data WsTransport = WsTransport + { -- | Send one text frame. + wsSend :: BS.ByteString -> IO (), + -- | Receive one text frame, blocking until it arrives. + wsReceive :: IO BS.ByteString + } + +-- | Subscribes to a signature and waits for its terminal notification, +-- returning the slot it was confirmed in. +-- +-- This is the push-based counterpart to +-- 'Network.Solana.SolanaWeb3.confirmTransaction': the node sends the result +-- as soon as the signature reaches @commitment@ rather than being polled for +-- it. Because @signatureSubscribe@ cancels itself once that notification is +-- sent, a successful wait leaves nothing to clean up. +-- +-- Frames that belong to other subscriptions, and early @receivedSignature@ +-- notifications, are skipped. The whole exchange -- subscribe, acknowledge, +-- notify -- is bounded by @timeoutSeconds@. +-- +-- Returns the confirming slot, or 'Left' describing a transaction that failed +-- on-chain, a JSON-RPC error, an unparseable frame, or the timeout. Exceptions +-- raised by the transport itself (a closed connection, for instance) are not +-- caught. +-- +-- A wait that ends in a timeout, a bad frame, or an on-chain failure may leave +-- the subscription open, because only the terminal notification retires it. +-- That costs nothing if the connection is about to be closed, which is the +-- common case; a caller that keeps the connection alive should cancel it with +-- 'signatureUnsubscribeRequest'. Note also that this reads frames directly +-- from the transport, so one connection supports one wait at a time — +-- multiplexing several concurrent subscriptions needs a reader loop +-- dispatching on 'parseWsMessage', which this function deliberately is not. +awaitSignature :: WsTransport -> RequestId -> Maybe String -> Int -> SolanaSignature -> IO (Either String Slot) +awaitSignature transport reqId mCommitment timeoutSeconds sig = do + result <- timeout (timeoutSeconds * 1000000) $ do + wsSend transport (signatureSubscribeRequest reqId sig mCommitment False) + subId <- awaitAck + either (pure . Left) awaitNotice subId + pure (fromMaybe (Left ("awaitSignature: timed out waiting for " <> show sig)) result) + where + -- Read until the acknowledgement for our own request id arrives. + awaitAck = do + msg <- next + case msg of + Left err -> pure (Left err) + Right (SubscribeAck rid subId) | rid == reqId -> pure (Right subId) + Right (WsErrorMessage rid code message) + | rid == Just reqId || isNothing rid -> + pure (Left ("awaitSignature: subscription failed (" <> show code <> "): " <> message)) + Right _ -> awaitAck + + -- Read until this subscription's terminal notification arrives. + awaitNotice subId = do + msg <- next + case msg of + Left err -> pure (Left err) + Right (SignatureNotice sub n) + | sub == subId, + not (snReceived n) -> + pure $ case snErr n of + Nothing -> Right (snSlot n) + Just err -> Left ("awaitSignature: transaction failed on-chain: " <> show err) + Right _ -> awaitNotice subId + + next = either (Left . ("awaitSignature: " <>)) Right . parseWsMessage <$> wsReceive transport diff --git a/src/Network/Solana/SolanaWeb3.hs b/src/Network/Solana/SolanaWeb3.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/SolanaWeb3.hs @@ -0,0 +1,271 @@ +-- | +-- Module : Network.Solana.SolanaWeb3 +-- Description : High-level helpers that bundle common Solana client workflows. +-- +-- Convenience layer on top of the JSON-RPC bindings: build, sign, and submit a +-- transaction in one call, print account balances, and pause execution while +-- waiting for confirmation. Intended for scripts and demos; for finer control +-- over blockhash selection, error handling, and confirmation strategy use +-- "Network.Solana.Core.Message" and "Network.Solana.RPC.HTTP.Transaction" +-- directly. +-- +-- Also bundles typed fetch helpers ('getTokenAccount', 'getMint', +-- 'getLookupTable', 'getStakeAccount', 'getNonceAccount', +-- 'getMetadataAccount') that fetch an account over RPC and decode its state +-- with the corresponding on-chain-state decoder, so callers don't have to +-- extract and decode 'Network.Solana.Core.Account.AccountData' by hand; like +-- every other helper in this module, they require a reachable RPC node and +-- are compile-verified only. +module Network.Solana.SolanaWeb3 where + +import Control.Concurrent (threadDelay) +import Control.Exception (throwIO) +import Control.Monad.IO.Class +import Data.ByteString qualified as BS +import Data.Maybe (fromMaybe, isNothing) +import Data.Word (Word64) +import Network.Solana.Core.Account (AccountData (..), AccountInfo (dataField)) +import Network.Solana.Core.Crypto +import Network.Solana.Core.Instruction +import Network.Solana.Core.Message (newDurableNonceTransactionIntentWithPayer, newTransactionIntent) +import Network.Solana.Core.VersionedMessage qualified as VM +import Network.Solana.Metaplex.TokenMetadata qualified as TM +import Network.Solana.NativePrograms.AddressLookupTable qualified as ALT +import Network.Solana.NativePrograms.Stake qualified as Stake +import Network.Solana.NativePrograms.SystemProgram qualified as SP +import Network.Solana.RPC.HTTP.Account (confirmationStatusTxStatus, errTxStatus, getAccountInfo, getAccountInfo', getBalance, getSignatureStatuses) +import Network.Solana.RPC.HTTP.Block (getTheLatestBlockhash) +import Network.Solana.RPC.HTTP.Chain (PrioritizationFee (prioritizationFee), getRecentPrioritizationFees, percentilePriorityFee) +import Network.Solana.RPC.HTTP.Transaction +import Network.Solana.RPC.HTTP.Types (ConfigurationObject, cfgJustEncodingBase64, commitment, value) +import Network.Solana.SplPrograms.Token qualified as Tok +import Network.Web3 hiding (AccountData, value) + +-- | Builds, signs, and submits a transaction that executes the given +-- instructions, returning its signature. +-- +-- Fetches the latest blockhash from the cluster, compiles the instructions +-- into a message, signs it with the given keys (the first key is the fee +-- payer), and broadcasts the result with 'sendTransaction'. +-- +-- Throws a 'CompileException' if an instruction references an account key +-- that cannot be resolved in the compiled message. +newTransaction :: [SolanaPrivateKey] -> [Instruction] -> Web3 SolanaSignature +newTransaction signers instructions = do + let newTxInt = newTransactionIntent signers instructions + bh <- getTheLatestBlockhash + signedTx <- either (liftIO . throwIO) pure (newTxInt bh) + sendTransaction signedTx + +-- | Configuration used to fetch the nonce account in 'newNonceTransaction': +-- base64 encoding (needed to decode the account's data, same as +-- 'Network.Solana.RPC.HTTP.Account.getAccountInfo') plus an explicit +-- @confirmed@ commitment, so a recently created or recently advanced nonce +-- account is not missed by the node's default @finalized@ commitment. +cfgNonceAccountConfirmed :: ConfigurationObject +cfgNonceAccountConfirmed = cfgJustEncodingBase64 {commitment = Just "confirmed"} + +-- | Builds, signs, and submits a durable-nonce transaction with an +-- explicitly named fee payer that executes the given instructions, +-- returning its signature. +-- +-- Reads the given nonce account at @confirmed@ commitment to avoid +-- stale-nonce races (a nonce account fetched at the node's default +-- @finalized@ commitment may appear not-found or stale immediately after +-- creation or after being advanced), then builds the transaction with +-- 'newDurableNonceTransactionIntentWithPayer', which prepends the +-- nonce-advance instruction ahead of the given instructions and uses the +-- nonce account's durable nonce in place of a recent block hash (so the +-- transaction never expires, unlike 'newTransaction'). The fee payer is +-- always account 0 (sponsored fees are supported), and the given signers +-- may be listed in any order — they must include private keys +-- corresponding to both the payer and the nonce account's authority +-- (@nsAuthority@), or the resulting transaction will be rejected on +-- submission. Requires a reachable RPC node. +-- +-- Throws @'userError' "newNonceTransaction: nonce account not found"@ if +-- the account does not exist, and @'userError' "newNonceTransaction: nonce +-- account not initialized"@ if it exists but has not been initialized as a +-- nonce account -- distinct from each other and from the 'CompileException' +-- thrown if an instruction references an account key that cannot be +-- resolved in the compiled message. +newNonceTransaction :: SolanaPublicKey -> [SolanaPrivateKey] -> SolanaPublicKey -> [Instruction] -> Web3 SolanaSignature +newNonceTransaction payer signers nonceAccount instructions = do + mAccInfo <- value <$> getAccountInfo' nonceAccount cfgNonceAccountConfirmed + case mAccInfo of + Nothing -> liftIO . throwIO . userError $ "newNonceTransaction: nonce account not found" + Just acc -> do + nonceState <- + either + (liftIO . throwIO . userError . ("newNonceTransaction: state decode failed: " <>)) + pure + (accountDataBytes (dataField acc) >>= SP.decodeNonceAccount) + case nonceState of + SP.NonceUninitialized -> liftIO . throwIO . userError $ "newNonceTransaction: nonce account not initialized" + SP.NonceInitialized authority durableNonce _ -> do + let newTxInt = newDurableNonceTransactionIntentWithPayer payer signers nonceAccount authority instructions + signedTx <- either (liftIO . throwIO) pure (newTxInt durableNonce) + sendTransaction signedTx + +-- | Estimates a priority fee (in micro-lamports per compute unit) for +-- landing a transaction that writes to the given accounts, as the @p@-th +-- percentile of recent per-compute-unit fees observed for them (via +-- 'getRecentPrioritizationFees' and 'percentilePriorityFee'). +-- +-- Heuristic only: recent fees are no guarantee of what is needed to land +-- the next transaction. Returns @0@ if no recent priority fees were +-- observed for the given accounts. Requires a reachable RPC node. +estimatePriorityFee :: [SolanaPublicKey] -> Double -> Web3 Word64 +estimatePriorityFee addresses p = do + fees <- getRecentPrioritizationFees (Just addresses) + pure (percentilePriorityFee p (map prioritizationFee fees)) + +-- | Prints the balance of each of the given accounts to standard output using 'printBalance'. +printBalances :: [SolanaPublicKey] -> Web3 () +printBalances = mapM_ printBalance + +-- | Fetches the balance of the given account with 'getBalance' and prints it to standard output. +printBalance :: SolanaPublicKey -> Web3 () +printBalance addr = do + balance <- getBalance addr + liftIO $ putStrLn $ "Balance for " <> show addr <> " is: " <> show balance + +-- | Suspends execution for the given number of seconds, printing a notice first. +-- A crude way to wait for transaction confirmation; prefer polling +-- 'Network.Solana.RPC.HTTP.Account.getSignatureStatuses' in real applications. +wait :: Int -> Web3 () +wait s = liftIO $ do + putStrLn ("Wait " <> show s <> " seconds to make sure tx is confirmed ..") + threadDelay (s * 1000000) + +-- | Polls 'Network.Solana.RPC.HTTP.Account.getSignatureStatuses' once a +-- second, up to 30 times, until the given signature reaches @confirmed@ or +-- @finalized@ status. +-- +-- Returns 'True' only if the status reaches the target commitment /and/ the +-- node reports no on-chain error for it (its @err@ field is 'Nothing'); a +-- transaction that landed but failed on-chain (e.g. a program error) yields +-- 'False', not 'True'. Also returns 'False' if it does not confirm within +-- the poll budget. +confirmTransaction :: SolanaSignature -> Web3 Bool +confirmTransaction sig = go (30 :: Int) + where + go 0 = pure False + go n = do + statuses <- getSignatureStatuses [sig] + case statuses of + [Just s] + | confirmationStatusTxStatus s `elem` [Just "confirmed", Just "finalized"] -> + pure (isNothing (errTxStatus s)) + [_] -> wait 1 >> go (n - 1) + _ -> liftIO . throwIO . userError $ + "confirmTransaction: expected exactly one status for one signature, got " <> show (length statuses) + +------------------------------------------------------------------------------------------------ + +-- * Account-state fetch helpers + +------------------------------------------------------------------------------------------------ + +-- | Extracts the raw bytes backing an account's @data@ field. Every fetch +-- helper in this module requests base64 encoding (see +-- 'Network.Solana.RPC.HTTP.Account.getAccountInfo'), so +-- 'Network.Solana.Core.Account.AccountDataJSON' should never occur in +-- practice; if it does, it is reported the same way as any other decode +-- failure. +accountDataBytes :: AccountData -> Either String BS.ByteString +accountDataBytes (AccountDataBinary bs) = Right bs +accountDataBytes (AccountDataJSON _) = Left "account data was not base64-encoded" + +-- | Fetches the given account with 'Network.Solana.RPC.HTTP.Account.getAccountInfo' +-- and decodes its data with the given decoder, prefixing any failure message +-- with the given label. +-- +-- Returns 'Nothing' if the account does not exist. Propagates the underlying +-- JSON-RPC exception on RPC failure, same as every other RPC-backed helper in +-- this module. Throws @'userError' (label <> ": state decode failed: " <> err)@ +-- if the account exists but its data cannot be decoded -- distinct from the +-- not-found case. +fetchAccountState :: String -> (BS.ByteString -> Either String a) -> SolanaPublicKey -> Web3 (Maybe a) +fetchAccountState label decodeFn addr = do + macc <- getAccountInfo addr + case macc of + Nothing -> pure Nothing + Just acc -> + either + (liftIO . throwIO . userError . ((label <> ": state decode failed: ") <>)) + (pure . Just) + (accountDataBytes (dataField acc) >>= decodeFn) + +-- | Fetches the given account and decodes it as an SPL Token account with +-- 'Tok.decodeTokenAccount'. +-- +-- Returns 'Nothing' if the account does not exist. Throws on RPC failure, per +-- 'fetchAccountState'. Throws @'userError' +-- ("getTokenAccount: state decode failed: " <> err)@ if the account exists +-- but is not a well-formed SPL Token account -- distinct from the not-found +-- case. +getTokenAccount :: SolanaPublicKey -> Web3 (Maybe Tok.TokenAccount) +getTokenAccount = fetchAccountState "getTokenAccount" Tok.decodeTokenAccount + +-- | Fetches the given account and decodes it as an SPL Token mint with +-- 'Tok.decodeMint'. +-- +-- Returns 'Nothing' if the account does not exist. Throws on RPC failure, per +-- 'fetchAccountState'. Throws @'userError' +-- ("getMint: state decode failed: " <> err)@ if the account exists but is +-- not a well-formed mint -- distinct from the not-found case. +getMint :: SolanaPublicKey -> Web3 (Maybe Tok.Mint) +getMint = fetchAccountState "getMint" Tok.decodeMint + +-- | Fetches the given address lookup table account, decodes it with +-- 'ALT.decodeLookupTable', and bridges it into the +-- 'VM.AddressLookupTableAccount' shape 'Network.Solana.Core.VersionedMessage.compileV0Message' +-- expects (via 'ALT.lookupTableToAccount'), using the queried address as the +-- table's own key. +-- +-- Returns 'Nothing' if the account does not exist. Throws on RPC failure, per +-- 'fetchAccountState'. Throws @'userError' +-- ("getLookupTable: state decode failed: " <> err)@ if the account exists but +-- is not a well-formed lookup table -- distinct from the not-found case. +getLookupTable :: SolanaPublicKey -> Web3 (Maybe VM.AddressLookupTableAccount) +getLookupTable key = do + mState <- fetchAccountState "getLookupTable" ALT.decodeLookupTable key + pure (ALT.lookupTableToAccount key <$> mState) + +-- | Fetches the given account and decodes it as a stake account with +-- 'Stake.decodeStakeAccount'. +-- +-- Returns 'Nothing' if the account does not exist. Throws on RPC failure, per +-- 'fetchAccountState'. Throws @'userError' +-- ("getStakeAccount: state decode failed: " <> err)@ if the account exists +-- but is not a well-formed stake account -- distinct from the not-found case. +getStakeAccount :: SolanaPublicKey -> Web3 (Maybe Stake.StakeState) +getStakeAccount = fetchAccountState "getStakeAccount" Stake.decodeStakeAccount + +-- | Fetches the given account and decodes it as a nonce account with +-- 'SP.decodeNonceAccount'. +-- +-- Returns 'Nothing' if the account does not exist. Throws on RPC failure, per +-- 'fetchAccountState'. Throws @'userError' +-- ("getNonceAccount: state decode failed: " <> err)@ if the account exists +-- but is not a well-formed nonce account -- distinct from the not-found case. +getNonceAccount :: SolanaPublicKey -> Web3 (Maybe SP.NonceState) +getNonceAccount = fetchAccountState "getNonceAccount" SP.decodeNonceAccount + +-- | Fetches the Metaplex metadata account for the given mint (deriving its +-- PDA with 'TM.deriveMetadataAddress') and decodes it with +-- 'TM.decodeMetadata'. +-- +-- Calls 'error' if the metadata PDA cannot be derived, matching the +-- precedent set by 'Network.Solana.Metaplex.TokenMetadata.createMetadataAccountV3' +-- (practically unreachable: requires every bump candidate to land on-curve). +-- Otherwise, returns 'Nothing' if the metadata account does not exist. +-- Throws on RPC failure, per 'fetchAccountState'. Throws @'userError' +-- ("getMetadataAccount: state decode failed: " <> err)@ if the account +-- exists but is not well-formed metadata -- distinct from the not-found case. +getMetadataAccount :: SolanaPublicKey -> Web3 (Maybe TM.Metadata) +getMetadataAccount mint = + fetchAccountState "getMetadataAccount" TM.decodeMetadata pda + where + pda = fromMaybe (error "getMetadataAccount: metadata PDA derivation failed") (TM.deriveMetadataAddress mint) diff --git a/src/Network/Solana/SplPrograms/AssociatedTokenAccount.hs b/src/Network/Solana/SplPrograms/AssociatedTokenAccount.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/SplPrograms/AssociatedTokenAccount.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Client for the Associated Token Account (ATA) program: derives the +-- canonical token account address for a (wallet, mint) pair and builds +-- create instructions. +module Network.Solana.SplPrograms.AssociatedTokenAccount where + +import Data.Binary (Binary (..), Get, Put) +import Data.Binary.Get (getWord8) +import Data.Binary.Put (putWord8) +import Data.Maybe (fromMaybe) +import Network.Solana.Core.Crypto (SolanaPublicKey, getSolanaPublicKeyRaw) +import Network.Solana.Core.Instruction +import Network.Solana.Core.Pda (findProgramAddress) +import Network.Solana.NativePrograms.SystemProgram qualified as SystemProgram +import Network.Solana.SplPrograms.Token qualified as Token + +-- | Associated Token Account program address. +associatedTokenProgramId :: SolanaPublicKey +associatedTokenProgramId = "ATokenGPvbdGVxr1b2hvZbsiqW5xWH25efTNsLJA8knL" + +-- | System program reference (re-exported for account-meta lists). +systemProgramRef :: SolanaPublicKey +systemProgramRef = SystemProgram.systemProgramId + +-- | ATA instruction data: a single borsh discriminant byte. +data AtaInstruction = Create | CreateIdempotent + deriving (Eq, Show) + +instance Binary AtaInstruction where + put :: AtaInstruction -> Put + put Create = putWord8 0 + put CreateIdempotent = putWord8 1 + get :: Get AtaInstruction + get = do + b <- getWord8 + case b of + 0 -> pure Create + 1 -> pure CreateIdempotent + _ -> fail ("AtaInstruction: unknown discriminant " <> show b) + +-- | Derive the associated token account address for a wallet and mint: +-- the PDA of [wallet, token program, mint] under the ATA program. +getAssociatedTokenAddress :: SolanaPublicKey -> SolanaPublicKey -> Maybe SolanaPublicKey +getAssociatedTokenAddress wallet mint = + fst + <$> findProgramAddress + [ getSolanaPublicKeyRaw wallet, + getSolanaPublicKeyRaw Token.tokenProgramId, + getSolanaPublicKeyRaw mint + ] + associatedTokenProgramId + +ataMetas :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> [AccountMeta] +ataMetas funder wallet mint = + let ata = fromMaybe (error "getAssociatedTokenAddress: derivation failed") (getAssociatedTokenAddress wallet mint) + in [ AccountMeta {accountPubKey = funder, isSigner = True, isWritable = True}, + AccountMeta {accountPubKey = ata, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = wallet, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = mint, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = systemProgramRef, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = Token.tokenProgramId, isSigner = False, isWritable = False} + ] + +-- | Create the associated token account for (wallet, mint), paid by the funder. +-- Fails the transaction if it already exists. +createAssociatedTokenAccount :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> Instruction +createAssociatedTokenAccount funder wallet mint = + mkInstruction associatedTokenProgramId (ataMetas funder wallet mint) Create + +-- | Like 'createAssociatedTokenAccount' but succeeds (no-op) if the account +-- already exists. +createAssociatedTokenAccountIdempotent :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> Instruction +createAssociatedTokenAccountIdempotent funder wallet mint = + mkInstruction associatedTokenProgramId (ataMetas funder wallet mint) CreateIdempotent diff --git a/src/Network/Solana/SplPrograms/Memo.hs b/src/Network/Solana/SplPrograms/Memo.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/SplPrograms/Memo.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.Solana.SplPrograms.Memo where + +import Data.Binary +import Data.Binary.Get (getRemainingLazyByteString) +import Data.Binary.Put (putByteString) +import Data.ByteString.Lazy qualified as BL +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Network.Solana.Core.Crypto (SolanaPublicKey) +import Network.Solana.Core.Instruction + +-- | SPL Memo program (v2) address. The program validates a string of UTF-8 +-- encoded characters and verifies that any accounts provided are signers of +-- the transaction. +memoProgramId :: SolanaPublicKey +memoProgramId = "MemoSq4gqABAXKb96qnH8TysNcWxMyWCqXgDLGmfcHr" + +-- | Memo instruction data: the raw UTF-8 bytes of the memo text +-- (no discriminant, no length prefix). The 'Binary' 'get' decodes leniently +-- by design: invalid UTF-8 sequences are replaced (never fails), and all +-- remaining input is consumed as the memo text. Encoding via 'put' is the +-- production path used when building instructions; decoding exists mainly +-- for round-tripping and inspection. +newtype MemoData = MemoData String + deriving (Eq, Show) + +instance Binary MemoData where + put :: MemoData -> Put + put (MemoData s) = putByteString (TE.encodeUtf8 (T.pack s)) + get :: Get MemoData + get = MemoData . T.unpack . TE.decodeUtf8Lenient . BL.toStrict <$> getRemainingLazyByteString + +-- | Creates a memo instruction from the memo text and the list of signer accounts +-- (may be empty). The memo program verifies each provided account signed the transaction. +-- # Account references +-- 0..n. `[SIGNER]` Signer accounts +buildMemo :: String -> [SolanaPublicKey] -> Instruction +buildMemo text signers = + mkInstruction + memoProgramId + [AccountMeta {accountPubKey = s, isSigner = True, isWritable = False} | s <- signers] + (MemoData text) diff --git a/src/Network/Solana/SplPrograms/Token.hs b/src/Network/Solana/SplPrograms/Token.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/SplPrograms/Token.hs @@ -0,0 +1,499 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Client for the SPL Token program: +-- Instruction data uses SPL Token's hand-rolled pack format (u8 discriminant, +-- little-endian integers, raw 32-byte pubkeys, and optional pubkeys encoded +-- as a 1-byte tag followed by the key when present) — this is NOT bincode. +module Network.Solana.SplPrograms.Token where + +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BL +import GHC.Generics (Generic) +import Network.Solana.Core.Crypto +import Network.Solana.Core.Instruction +import Network.Solana.Sysvar qualified as Sysvar + +-- | Token account state: Uninitialized (0), Initialized (1), or Frozen (2). +data AccountState = TokenAccountUninitialized | TokenAccountInitialized | TokenAccountFrozen + deriving (Eq, Show, Enum) + +-- | SPL Token account state (165 bytes fixed). +data TokenAccount = TokenAccount + { taMint :: SolanaPublicKey, + taOwner :: SolanaPublicKey, + taAmount :: Word64, + taDelegate :: Maybe SolanaPublicKey, + taState :: AccountState, + taIsNative :: Maybe Word64, + taDelegatedAmount :: Word64, + taCloseAuthority :: Maybe SolanaPublicKey + } + deriving (Eq, Show) + +-- | SPL Token mint state (82 bytes fixed). +data Mint = Mint + { mMintAuthority :: Maybe SolanaPublicKey, + mSupply :: Word64, + mDecimals :: Word8, + mIsInitialized :: Bool, + mFreezeAuthority :: Maybe SolanaPublicKey + } + deriving (Eq, Show) + +-- | Helper for parsing fixed-width state COption (4-byte LE tag + payload). +getStateCOption :: Int -> Get a -> Get (Maybe a) +getStateCOption payloadLen inner = do + tag <- getWord32le + case tag of + 0 -> skip payloadLen >> pure Nothing + 1 -> Just <$> inner + _ -> fail ("state COption: invalid tag " <> show tag) + +-- | Decode a SPL Token account state from bytes (exactly 165 bytes). +decodeTokenAccount :: BS.ByteString -> Either String TokenAccount +decodeTokenAccount bs + | BS.length bs /= 165 = Left ("TokenAccount: expected 165 bytes, got " <> show (BS.length bs)) + | otherwise = case runGetOrFail getTokenAccount (BL.fromStrict bs) of + Left (_, _, err) -> Left err + Right (_, _, ta) -> Right ta + where + getTokenAccount = + TokenAccount + <$> get + <*> get + <*> getWord64le + <*> getStateCOption 32 get + <*> getAccountState + <*> getStateCOption 8 getWord64le + <*> getWord64le + <*> getStateCOption 32 get + getAccountState = do + byte <- getWord8 + if byte <= 2 + then pure (toEnum (fromIntegral byte)) + else fail ("AccountState: invalid value " <> show byte) + +-- | Decode a SPL Token mint state from bytes (exactly 82 bytes). +decodeMint :: BS.ByteString -> Either String Mint +decodeMint bs + | BS.length bs /= 82 = Left ("Mint: expected 82 bytes, got " <> show (BS.length bs)) + | otherwise = case runGetOrFail getMint (BL.fromStrict bs) of + Left (_, _, err) -> Left err + Right (_, _, m) -> Right m + where + getMint = + Mint + <$> getStateCOption 32 get + <*> getWord64le + <*> getWord8 + <*> getIsInitialized + <*> getStateCOption 32 get + getIsInitialized = do + byte <- getWord8 + case byte of + 0 -> pure False + 1 -> pure True + _ -> fail ("Mint: invalid is_initialized byte " <> show byte) + +-- | SPL Token program address. +tokenProgramId :: SolanaPublicKey +tokenProgramId = "TokenkegQfeZyiNwAJbNbGKPFXCWuBvf9Ss623VQ5DA" + +-- | Authorities a token mint or account can carry (SPL @AuthorityType@, u8 0-3). +data AuthorityType + = MintTokens + | FreezeAuthority + | AccountOwner + | CloseAuthority + deriving (Eq, Show, Enum, Bounded, Generic) + +-- | SPL Token instructions 0-20 (instructions 21-24 are deferred post-1.0). +data TokenInstruction + = InitializeMint {tiDecimals :: Word8, tiMintAuthority :: SolanaPublicKey, tiFreezeAuthority :: Maybe SolanaPublicKey} + | InitializeAccount + | InitializeMultisig {tiM :: Word8} + | Transfer {tiAmount :: Word64} + | Approve {tiAmount :: Word64} + | Revoke + | SetAuthority {tiAuthorityType :: AuthorityType, tiNewAuthority :: Maybe SolanaPublicKey} + | MintTo {tiAmount :: Word64} + | Burn {tiAmount :: Word64} + | CloseAccount + | FreezeAccount + | ThawAccount + | TransferChecked {tiAmount :: Word64, tiDecimals :: Word8} + | ApproveChecked {tiAmount :: Word64, tiDecimals :: Word8} + | MintToChecked {tiAmount :: Word64, tiDecimals :: Word8} + | BurnChecked {tiAmount :: Word64, tiDecimals :: Word8} + | InitializeAccount2 {tiOwner :: SolanaPublicKey} + | SyncNative + | InitializeAccount3 {tiOwner :: SolanaPublicKey} + | InitializeMultisig2 {tiM :: Word8} + | InitializeMint2 {tiDecimals :: Word8, tiMintAuthority :: SolanaPublicKey, tiFreezeAuthority :: Maybe SolanaPublicKey} + deriving (Eq, Show, Generic) + +putCOptionPubkey :: Maybe SolanaPublicKey -> Put +putCOptionPubkey Nothing = putWord8 0 +putCOptionPubkey (Just pk) = do + putWord8 1 + putByteString (getSolanaPublicKeyRaw pk) + +getCOptionPubkey :: Get (Maybe SolanaPublicKey) +getCOptionPubkey = do + tag <- getWord8 + case tag of + 0 -> pure Nothing + 1 -> Just <$> get + _ -> fail ("COption: invalid tag " <> show tag) + +instance Binary TokenInstruction where + put :: TokenInstruction -> Put + put (InitializeMint decimals mintAuth freezeAuth) = do + putWord8 0 + putWord8 decimals + putByteString (getSolanaPublicKeyRaw mintAuth) + putCOptionPubkey freezeAuth + put InitializeAccount = putWord8 1 + put (InitializeMultisig m) = do + putWord8 2 + putWord8 m + put (Transfer amount) = do + putWord8 3 + putWord64le amount + put (Approve amount) = do + putWord8 4 + putWord64le amount + put Revoke = putWord8 5 + put (SetAuthority authType newAuth) = do + putWord8 6 + putWord8 (fromIntegral (fromEnum authType)) + putCOptionPubkey newAuth + put (MintTo amount) = do + putWord8 7 + putWord64le amount + put (Burn amount) = do + putWord8 8 + putWord64le amount + put CloseAccount = putWord8 9 + put FreezeAccount = putWord8 10 + put ThawAccount = putWord8 11 + put (TransferChecked amount decimals) = do + putWord8 12 + putWord64le amount + putWord8 decimals + put (ApproveChecked amount decimals) = do + putWord8 13 + putWord64le amount + putWord8 decimals + put (MintToChecked amount decimals) = do + putWord8 14 + putWord64le amount + putWord8 decimals + put (BurnChecked amount decimals) = do + putWord8 15 + putWord64le amount + putWord8 decimals + put (InitializeAccount2 owner) = do + putWord8 16 + putByteString (getSolanaPublicKeyRaw owner) + put SyncNative = putWord8 17 + put (InitializeAccount3 owner) = do + putWord8 18 + putByteString (getSolanaPublicKeyRaw owner) + put (InitializeMultisig2 m) = do + putWord8 19 + putWord8 m + put (InitializeMint2 decimals mintAuth freezeAuth) = do + putWord8 20 + putWord8 decimals + putByteString (getSolanaPublicKeyRaw mintAuth) + putCOptionPubkey freezeAuth + + get :: Get TokenInstruction + get = do + disc <- getWord8 + case disc of + 0 -> InitializeMint <$> getWord8 <*> get <*> getCOptionPubkey + 1 -> pure InitializeAccount + 2 -> InitializeMultisig <$> getWord8 + 3 -> Transfer <$> getWord64le + 4 -> Approve <$> getWord64le + 5 -> pure Revoke + 6 -> SetAuthority <$> getAuthorityType <*> getCOptionPubkey + 7 -> MintTo <$> getWord64le + 8 -> Burn <$> getWord64le + 9 -> pure CloseAccount + 10 -> pure FreezeAccount + 11 -> pure ThawAccount + 12 -> TransferChecked <$> getWord64le <*> getWord8 + 13 -> ApproveChecked <$> getWord64le <*> getWord8 + 14 -> MintToChecked <$> getWord64le <*> getWord8 + 15 -> BurnChecked <$> getWord64le <*> getWord8 + 16 -> InitializeAccount2 <$> get + 17 -> pure SyncNative + 18 -> InitializeAccount3 <$> get + 19 -> InitializeMultisig2 <$> getWord8 + 20 -> InitializeMint2 <$> getWord8 <*> get <*> getCOptionPubkey + _ -> fail ("TokenInstruction: unknown discriminant " <> show disc) + where + getAuthorityType = do + b <- getWord8 + if b <= 3 + then pure (toEnum (fromIntegral b)) + else fail ("AuthorityType: invalid value " <> show b) + +-- | Rent sysvar (re-exported for account-meta lists). +rentSysvar :: SolanaPublicKey +rentSysvar = Sysvar.rent + +-- Owner-or-multisig meta convention (mirrors the Rust @spl-token@ builders): +-- with an empty signer list the owner itself signs; with a non-empty list the +-- owner is a readonly non-signer (the multisig account) and each listed key +-- is a readonly signer. +ownerMetas :: SolanaPublicKey -> [SolanaPublicKey] -> [AccountMeta] +ownerMetas owner signers = + AccountMeta {accountPubKey = owner, isSigner = null signers, isWritable = False} + : [AccountMeta {accountPubKey = s, isSigner = True, isWritable = False} | s <- signers] + +-- | Initialize a new mint. Accounts: 0. `[WRITE]` mint, 1. `[]` rent sysvar. +initializeMint :: SolanaPublicKey -> Word8 -> SolanaPublicKey -> Maybe SolanaPublicKey -> Instruction +initializeMint mint decimals mintAuthority freezeAuthority = + mkInstruction + tokenProgramId + [ AccountMeta {accountPubKey = mint, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = rentSysvar, isSigner = False, isWritable = False} + ] + (InitializeMint decimals mintAuthority freezeAuthority) + +-- | Initialize a token account. Accounts: 0. `[WRITE]` account, 1. `[]` mint, 2. `[]` owner, 3. `[]` rent sysvar. +initializeAccount :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> Instruction +initializeAccount account mint owner = + mkInstruction + tokenProgramId + [ AccountMeta {accountPubKey = account, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = mint, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = owner, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = rentSysvar, isSigner = False, isWritable = False} + ] + InitializeAccount + +-- | Transfer tokens. Accounts: 0. `[WRITE]` source, 1. `[WRITE]` destination, +-- then owner-or-multisig metas. +transfer :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> [SolanaPublicKey] -> Word64 -> Instruction +transfer source destination owner signers amount = + mkInstruction + tokenProgramId + ( [ AccountMeta {accountPubKey = source, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = destination, isSigner = False, isWritable = True} + ] + <> ownerMetas owner signers + ) + (Transfer amount) + +-- | Approve a delegate. Accounts: 0. `[WRITE]` source, 1. `[]` delegate, then owner metas. +approve :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> [SolanaPublicKey] -> Word64 -> Instruction +approve source delegate owner signers amount = + mkInstruction + tokenProgramId + ( [ AccountMeta {accountPubKey = source, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = delegate, isSigner = False, isWritable = False} + ] + <> ownerMetas owner signers + ) + (Approve amount) + +-- | Revoke a delegate. Accounts: 0. `[WRITE]` source, then owner metas. +revoke :: SolanaPublicKey -> SolanaPublicKey -> [SolanaPublicKey] -> Instruction +revoke source owner signers = + mkInstruction + tokenProgramId + (AccountMeta {accountPubKey = source, isSigner = False, isWritable = True} : ownerMetas owner signers) + Revoke + +-- | Change a mint or account authority. Accounts: 0. `[WRITE]` mint/account, then owner metas. +setAuthority :: SolanaPublicKey -> AuthorityType -> Maybe SolanaPublicKey -> SolanaPublicKey -> [SolanaPublicKey] -> Instruction +setAuthority owned authorityType newAuthority currentAuthority signers = + mkInstruction + tokenProgramId + (AccountMeta {accountPubKey = owned, isSigner = False, isWritable = True} : ownerMetas currentAuthority signers) + (SetAuthority authorityType newAuthority) + +-- | Mint new tokens. Accounts: 0. `[WRITE]` mint, 1. `[WRITE]` destination account, then owner metas. +mintTo :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> [SolanaPublicKey] -> Word64 -> Instruction +mintTo mint destination mintAuthority signers amount = + mkInstruction + tokenProgramId + ( [ AccountMeta {accountPubKey = mint, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = destination, isSigner = False, isWritable = True} + ] + <> ownerMetas mintAuthority signers + ) + (MintTo amount) + +-- | Burn tokens. Accounts: 0. `[WRITE]` account, 1. `[WRITE]` mint, then owner metas. +burn :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> [SolanaPublicKey] -> Word64 -> Instruction +burn account mint owner signers amount = + mkInstruction + tokenProgramId + ( [ AccountMeta {accountPubKey = account, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = mint, isSigner = False, isWritable = True} + ] + <> ownerMetas owner signers + ) + (Burn amount) + +-- | Close a token account, reclaiming its lamports. Accounts: 0. `[WRITE]` account, +-- 1. `[WRITE]` lamport destination, then owner metas. +closeAccount :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> [SolanaPublicKey] -> Instruction +closeAccount account destination owner signers = + mkInstruction + tokenProgramId + ( [ AccountMeta {accountPubKey = account, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = destination, isSigner = False, isWritable = True} + ] + <> ownerMetas owner signers + ) + CloseAccount + +-- | Freeze a token account. Accounts: 0. `[WRITE]` account, 1. `[]` mint, then freeze-authority metas. +freezeAccount :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> [SolanaPublicKey] -> Instruction +freezeAccount account mint freezeAuthority signers = + mkInstruction + tokenProgramId + ( [ AccountMeta {accountPubKey = account, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = mint, isSigner = False, isWritable = False} + ] + <> ownerMetas freezeAuthority signers + ) + FreezeAccount + +-- | Thaw a frozen token account. Same accounts as 'freezeAccount'. +thawAccount :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> [SolanaPublicKey] -> Instruction +thawAccount account mint freezeAuthority signers = + mkInstruction + tokenProgramId + ( [ AccountMeta {accountPubKey = account, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = mint, isSigner = False, isWritable = False} + ] + <> ownerMetas freezeAuthority signers + ) + ThawAccount + +-- | Transfer with decimals check. Accounts: 0. `[WRITE]` source, 1. `[]` mint, +-- 2. `[WRITE]` destination, then owner metas. +transferChecked :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> [SolanaPublicKey] -> Word64 -> Word8 -> Instruction +transferChecked source mint destination owner signers amount decimals = + mkInstruction + tokenProgramId + ( [ AccountMeta {accountPubKey = source, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = mint, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = destination, isSigner = False, isWritable = True} + ] + <> ownerMetas owner signers + ) + (TransferChecked amount decimals) + +-- | Sync a native (wrapped SOL) account's balance. Accounts: 0. `[WRITE]` account. +syncNative :: SolanaPublicKey -> Instruction +syncNative account = + mkInstruction + tokenProgramId + [AccountMeta {accountPubKey = account, isSigner = False, isWritable = True}] + SyncNative + +-- | Initialize a multisig account. The signer pubkeys are the full member set; +-- m is the number of required signatures (the Rust SDK validates 1 <= m <= 11 <= length signers +-- client-side; this builder, like the others in this module, performs no client-side validation). +-- # Account references +-- 0. `[WRITE]` Multisig account +-- 1. `[]` Rent sysvar +-- 2..n. `[]` Signer member accounts +initializeMultisig :: SolanaPublicKey -> [SolanaPublicKey] -> Word8 -> Instruction +initializeMultisig multisig members m = + mkInstruction + tokenProgramId + ( [ AccountMeta {accountPubKey = multisig, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = rentSysvar, isSigner = False, isWritable = False} + ] + <> [AccountMeta {accountPubKey = s, isSigner = False, isWritable = False} | s <- members] + ) + (InitializeMultisig m) + +-- | Like 'initializeMultisig' without the rent sysvar account. +initializeMultisig2 :: SolanaPublicKey -> [SolanaPublicKey] -> Word8 -> Instruction +initializeMultisig2 multisig members m = + mkInstruction + tokenProgramId + ( AccountMeta {accountPubKey = multisig, isSigner = False, isWritable = True} + : [AccountMeta {accountPubKey = s, isSigner = False, isWritable = False} | s <- members] + ) + (InitializeMultisig2 m) + +-- | 'approve' with decimals check. Accounts: 0. `[WRITE]` source, 1. `[]` mint, 2. `[]` delegate, then owner metas. +approveChecked :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> [SolanaPublicKey] -> Word64 -> Word8 -> Instruction +approveChecked source mint delegate owner signers amount decimals = + mkInstruction + tokenProgramId + ( [ AccountMeta {accountPubKey = source, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = mint, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = delegate, isSigner = False, isWritable = False} + ] + <> ownerMetas owner signers + ) + (ApproveChecked amount decimals) + +-- | 'mintTo' with decimals check. Accounts: 0. `[WRITE]` mint, 1. `[WRITE]` destination, then owner metas. +mintToChecked :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> [SolanaPublicKey] -> Word64 -> Word8 -> Instruction +mintToChecked mint destination mintAuthority signers amount decimals = + mkInstruction + tokenProgramId + ( [ AccountMeta {accountPubKey = mint, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = destination, isSigner = False, isWritable = True} + ] + <> ownerMetas mintAuthority signers + ) + (MintToChecked amount decimals) + +-- | 'burn' with decimals check. Accounts: 0. `[WRITE]` account, 1. `[WRITE]` mint, then owner metas. +burnChecked :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> [SolanaPublicKey] -> Word64 -> Word8 -> Instruction +burnChecked account mint owner signers amount decimals = + mkInstruction + tokenProgramId + ( [ AccountMeta {accountPubKey = account, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = mint, isSigner = False, isWritable = True} + ] + <> ownerMetas owner signers + ) + (BurnChecked amount decimals) + +-- | 'initializeAccount' with the owner in instruction data. Accounts: 0. `[WRITE]` account, 1. `[]` mint, 2. `[]` rent sysvar. +initializeAccount2 :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> Instruction +initializeAccount2 account mint owner = + mkInstruction + tokenProgramId + [ AccountMeta {accountPubKey = account, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = mint, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = rentSysvar, isSigner = False, isWritable = False} + ] + (InitializeAccount2 owner) + +-- | Like 'initializeAccount2' without the rent sysvar account. Accounts: 0. `[WRITE]` account, 1. `[]` mint. +initializeAccount3 :: SolanaPublicKey -> SolanaPublicKey -> SolanaPublicKey -> Instruction +initializeAccount3 account mint owner = + mkInstruction + tokenProgramId + [ AccountMeta {accountPubKey = account, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = mint, isSigner = False, isWritable = False} + ] + (InitializeAccount3 owner) + +-- | Like 'initializeMint' without the rent sysvar account. Accounts: 0. `[WRITE]` mint. +initializeMint2 :: SolanaPublicKey -> Word8 -> SolanaPublicKey -> Maybe SolanaPublicKey -> Instruction +initializeMint2 mint decimals mintAuthority freezeAuthority = + mkInstruction + tokenProgramId + [AccountMeta {accountPubKey = mint, isSigner = False, isWritable = True}] + (InitializeMint2 decimals mintAuthority freezeAuthority) diff --git a/src/Network/Solana/Sysvar.hs b/src/Network/Solana/Sysvar.hs new file mode 100644 --- /dev/null +++ b/src/Network/Solana/Sysvar.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Solana.Sysvar +-- Description : Definitions of Solana Sysvar public keys for accessing blockchain state data. +-- Copyright : (c) 2024 +-- +-- This module provides convenient access to Solana's sysvars, special accounts that +-- store critical state data of the blockchain. These sysvars provide real-time data +-- such as the current slot, epoch schedules, fee rates, recent blockhashes, and more. +-- They are frequently referenced by Solana programs to obtain necessary blockchain +-- information during transaction execution. +module Network.Solana.Sysvar where + +import Network.Solana.Core.Crypto (SolanaPublicKey) + +-- | The Clock sysvar contains data on cluster time, including the current slot, epoch, and +-- estimated wall-clock Unix timestamp. It is updated every slot. +clock :: SolanaPublicKey +clock = "SysvarC1ock11111111111111111111111111111111" + +-- | The EpochSchedule sysvar contains epoch scheduling constants that are set in genesis, +-- and enables calculating the number of slots in a given epoch, the epoch for a given slot, etc. +epochSchedule :: SolanaPublicKey +epochSchedule = "SysvarEpochSchedu1e111111111111111111111111" + +-- | The Fees sysvar contains the fee calculator for the current slot. +-- It is updated every slot, based on the fee-rate governor. +fees :: SolanaPublicKey +fees = "SysvarFees111111111111111111111111111111111" + +-- | The Instructions sysvar contains the serialized instructions in a Message while that Message is being processed. +-- This allows program instructions to reference other instructions in the same transaction. +instructions :: SolanaPublicKey +instructions = "Sysvar1nstructions1111111111111111111111111" + +-- | The RecentBlockhashes sysvar contains the active recent blockhashes as well as their associated fee calculators. +-- It is updated every slot. +recentBlockhashes :: SolanaPublicKey +recentBlockhashes = "SysvarRecentB1ockHashes11111111111111111111" + +-- | The Rent sysvar contains the rental rate. +rent :: SolanaPublicKey +rent = "SysvarRent111111111111111111111111111111111" + +-- | The SlotHashes sysvar contains the most recent hashes of the slot's parent banks. It is updated every slot. +slotHashes :: SolanaPublicKey +slotHashes = "SysvarS1otHashes111111111111111111111111111" + +-- | The SlotHistory sysvar contains a bitvector of slots present over the last epoch. It is updated every slot. +slotHistory :: SolanaPublicKey +slotHistory = "SysvarS1otHistory11111111111111111111111111" + +-- | The StakeHistory sysvar contains the history of cluster-wide stake activations and de-activations per epoch. +-- It is updated at the start of every epoch. +stakeHistory :: SolanaPublicKey +stakeHistory = "SysvarStakeHistory1111111111111111111111111" + +-- | The EpochRewards sysvar holds a record of epoch rewards distribution in Solana, including block rewards and staking rewards. +epochRewards :: SolanaPublicKey +epochRewards = "SysvarEpochRewards1111111111111111111111111" + +-- | The LastRestartSlot sysvar contains the slot number of the last restart or 0 (zero) if none ever happened. +lastRestartSlot :: SolanaPublicKey +lastRestartSlot = "SysvarLastRestartS1ot1111111111111111111111" diff --git a/test-integration/Main.hs b/test-integration/Main.hs new file mode 100644 --- /dev/null +++ b/test-integration/Main.hs @@ -0,0 +1,62 @@ +-- 'sequentialTestGroup' (used below) is deprecated as of tasty-1.5.4 in +-- favor of 'dependentTestGroup', which has the same signature but only +-- exists since 1.5.4 -- newer than this project's declared @tasty ^>=1.5@ +-- lower bound. Using the deprecated name keeps the suite building against +-- the whole declared range instead of silently requiring 1.5.4+; suppressed +-- here rather than left as a stray warning. +{-# OPTIONS_GHC -Wno-deprecations #-} + +module Main (main) where + +import Control.Exception (SomeException, try) +import Network.Solana.RPC.HTTP.Chain (getHealth) +import Network.Web3.Provider (Provider (HttpProvider), runWeb3') +import System.Environment (lookupEnv) +import System.Exit (exitSuccess) +import System.IO (BufferMode (LineBuffering), hSetBuffering, stdout) +import System.Timeout (timeout) +import Test.Integration.Alt qualified as Alt +import Test.Integration.Nonce qualified as Nonce +import Test.Integration.PriorityFee qualified as PriorityFee +import Test.Integration.Setup (rpcUrl) +import Test.Integration.Token qualified as Token +import Test.Integration.Transfer qualified as Transfer +import Test.Integration.WebSocket qualified as WebSocket +import Test.Tasty +import Test.Tasty.HUnit + +-- | Probes 'rpcUrl' for a healthy validator (3 s timeout) before running the +-- suite. No validator reachable: skip green, unless @SOLANA_INTEGRATION=1@ is +-- set, in which case an unreachable validator is a loud failure instead of a +-- silent skip. +main :: IO () +main = do + hSetBuffering stdout LineBuffering + url <- rpcUrl + probe <- timeout 3000000 (try @SomeException (runWeb3' (HttpProvider url) getHealth)) + case probe of + Just (Right (Right "ok")) -> defaultMain integrationTests + _ -> do + force <- lookupEnv "SOLANA_INTEGRATION" + if force == Just "1" + then defaultMain (testCase "validator reachable" (assertFailure ("SOLANA_INTEGRATION=1 but no healthy validator at " <> url))) + else do + putStrLn ("integration-tests: no validator at " <> url <> " - skipping (start solana-test-validator, or set SOLANA_INTEGRATION=1 to require it)") + exitSuccess + +-- | The suite has no @-threaded@/@-N@ RTS options, so 'testGroup' already +-- runs its children one at a time today; 'sequentialTestGroup' makes that a +-- load-bearing property of the test tree itself rather than an accident of +-- the cabal stanza, so the five groups below (each hitting the same local +-- validator with fresh airdrops) can't start running concurrently if +-- @-threaded@ is ever added. 'AllFinish' keeps every group's results visible +-- even if an earlier one fails, matching today's behaviour. +-- +-- One consequence of the dependency chain 'sequentialTestGroup' builds: +-- filtering to a single later group (e.g. @Alt@) with tasty's @-p@ pattern +-- option also force-includes every earlier group in that run (tasty's +-- pattern filter keeps whatever a dependency-chained test depends on), so +-- @-p@ no longer isolates just the matched test the way it would under a +-- plain 'testGroup'. +integrationTests :: TestTree +integrationTests = sequentialTestGroup "integration" AllFinish [Transfer.tests, Token.tests, Nonce.tests, PriorityFee.tests, Alt.tests, WebSocket.tests] diff --git a/test-integration/Test/Integration/Alt.hs b/test-integration/Test/Integration/Alt.hs new file mode 100644 --- /dev/null +++ b/test-integration/Test/Integration/Alt.hs @@ -0,0 +1,63 @@ +-- | Live address-lookup-table coverage: create a table, extend it with +-- addresses, decode it back, and send a v0 transaction that resolves its +-- recipient through the table (the fee payer and the System Program id stay +-- static keys -- signers and program ids are never eligible for a lookup). +module Test.Integration.Alt (tests) where + +import Control.Exception (throwIO) +import Control.Monad.IO.Class (liftIO) +import Network.Solana.Core.Crypto (createSolanaKeyPair) +import Network.Solana.Core.VersionedMessage (altAddresses, newV0TransactionIntent) +import Network.Solana.NativePrograms.AddressLookupTable (createLookupTable, extendLookupTable) +import Network.Solana.NativePrograms.SystemProgram qualified as SystemProgram +import Network.Solana.RPC.HTTP.Account (getBalance) +import Network.Solana.RPC.HTTP.Block (getTheLatestBlockhash) +import Network.Solana.RPC.HTTP.Ledger (getSlot) +import Network.Solana.SolanaWeb3 (getLookupTable) +import Network.Web3.Provider (Web3) +import Test.Integration.Setup +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "Alt" + [testCase "on-chain ALT: create, extend, decode, v0 transfer through the table" (run altV0Flow)] + +-- | Creates a lookup table at the current finalized slot (guaranteed present +-- in the SlotHashes sysvar for the on-chain create check), extends it with a +-- recipient and a spare address, waits for the extension to finalize, checks +-- the decoded table holds the extended addresses, then sends a v0 +-- transaction that resolves the recipient through the table and checks the +-- transfer lands with the exact amount. +-- +-- The v0 send goes through 'sendConfirmedPreflight' rather than a +-- @finalized@-commitment send: an address added to a lookup table in slot +-- @S@ (the extend's landing slot, exposed on-chain as +-- @last_extended_slot@) only resolves in slots strictly greater than @S@. +-- 'confirmFinalized' guarantees the rooted bank has reached @S@, not passed +-- it, so a @finalized@-commitment preflight can simulate against a bank +-- sitting exactly at @S@ -- where the table's active-address count is still +-- zero (it was empty before this extend) -- and reject the send with +-- \"Transaction address table lookup uses an invalid index\", even though +-- the extend is itself finalized and a fresh 'getLookupTable' read shows the +-- addresses. See 'sendConfirmedPreflight' for the full rationale. +altV0Flow :: Web3 () +altV0Flow = do + (payerPk, payerSk) <- fundedKeypair 3_000_000_000 + recipient <- fst <$> liftIO createSolanaKeyPair + extra <- fst <$> liftIO createSolanaKeyPair + slot <- getSlot + let (createIx, tablePk) = createLookupTable payerPk payerPk slot + _ <- sendAndConfirm [payerSk] [createIx] + extendSig <- sendAndConfirm [payerSk] [extendLookupTable tablePk payerPk (Just payerPk) [recipient, extra]] + confirmFinalized extendSig + table <- requireJust "lookup table" =<< getLookupTable tablePk + liftIO (assertBool "extended addresses present" (recipient `elem` altAddresses table)) + bh <- getTheLatestBlockhash + tx <- either (liftIO . throwIO) pure (newV0TransactionIntent [payerSk] [SystemProgram.transfer payerPk recipient 200_000_000] [table] bh) + sig <- sendConfirmedPreflight tx + confirmFinalized sig + bal <- getBalance recipient + liftIO (bal @?= 200_000_000) diff --git a/test-integration/Test/Integration/Nonce.hs b/test-integration/Test/Integration/Nonce.hs new file mode 100644 --- /dev/null +++ b/test-integration/Test/Integration/Nonce.hs @@ -0,0 +1,56 @@ +-- | Live durable-nonce coverage: create and initialize a nonce account, use +-- it via 'newNonceTransaction' to send a transfer, and check the durable +-- nonce advances and the transfer lands. +module Test.Integration.Nonce (tests) where + +import Control.Exception (throwIO) +import Control.Monad.IO.Class (liftIO) +import Network.Solana.Core.Crypto (createSolanaKeyPair) +import Network.Solana.NativePrograms.SystemProgram qualified as SystemProgram +import Network.Solana.RPC.HTTP.Account (getBalance) +import Network.Solana.RPC.HTTP.Tokenomics (getMinimumBalanceForRentExemption) +import Network.Solana.SolanaWeb3 (getNonceAccount, newNonceTransaction) +import Network.Web3.Provider (Web3) +import Test.Integration.Setup +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "Nonce" + [testCase "durable-nonce flow: create, use via newNonceTransaction, nonce advances" (run nonceFlow)] + +-- | Creates and initializes a nonce account (payer as authority), checks its +-- decoded state before use, sends a transfer through 'newNonceTransaction', +-- and checks the durable nonce advanced and the transfer landed with the +-- exact amount. +-- +-- 'newNonceTransaction' reads the nonce account at @confirmed@ commitment +-- internally, but the node preflights its send against the @finalized@ +-- bank, so the create transaction is finalized before it is called. +nonceFlow :: Web3 () +nonceFlow = do + (payerPk, payerSk) <- fundedKeypair 2_000_000_000 + (noncePk, nonceSk) <- liftIO createSolanaKeyPair + rent <- getMinimumBalanceForRentExemption 80 + createSig <- + sendAndConfirm + [payerSk, nonceSk] + [ SystemProgram.createAccount payerPk noncePk rent 80 SystemProgram.systemProgramId, + SystemProgram.initializeNonceAccount noncePk payerPk + ] + confirmFinalized createSig -- newNonceTransaction preflights against the finalized bank + before <- requireJust "nonce account (before)" =<< getNonceAccount noncePk + nonceBefore <- case before of + SystemProgram.NonceInitialized auth dn _ -> liftIO (auth @?= payerPk) >> pure dn + _ -> liftIO (throwIO (userError "nonce account not initialized")) + recipient <- fst <$> liftIO createSolanaKeyPair + sig <- newNonceTransaction payerPk [payerSk] noncePk [SystemProgram.transfer payerPk recipient 100_000_000] + confirmFinalized sig + afterAcc <- requireJust "nonce account (after)" =<< getNonceAccount noncePk + case afterAcc of + SystemProgram.NonceInitialized _ dn _ -> liftIO (assertBool "durable nonce advanced" (dn /= nonceBefore)) + _ -> liftIO (throwIO (userError "nonce account no longer initialized")) + bal <- getBalance recipient + liftIO (bal @?= 100_000_000) diff --git a/test-integration/Test/Integration/PriorityFee.hs b/test-integration/Test/Integration/PriorityFee.hs new file mode 100644 --- /dev/null +++ b/test-integration/Test/Integration/PriorityFee.hs @@ -0,0 +1,52 @@ +-- | Live priority-fee coverage: a transfer prioritized with Compute Budget +-- instructions, and a smoke check that 'estimatePriorityFee' returns without +-- throwing. +module Test.Integration.PriorityFee (tests) where + +import Control.Monad.IO.Class (liftIO) +import Network.Solana.Core.Crypto (createSolanaKeyPair) +import Network.Solana.NativePrograms.ComputeBudget qualified as ComputeBudget +import Network.Solana.NativePrograms.SystemProgram qualified as SystemProgram +import Network.Solana.RPC.HTTP.Account (getBalance) +import Network.Solana.SolanaWeb3 (estimatePriorityFee) +import Network.Web3.Provider (Web3) +import Test.Integration.Setup +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "PriorityFee" + [ testCase "prioritized transfer lands with the exact amount" (run priorityFeeTransfer), + testCase "estimatePriorityFee smoke: returns without throwing" (run estimateSmoke) + ] + +-- | Sends a transfer prioritized with a compute unit limit and price, and +-- checks the recipient receives exactly the transferred amount. +priorityFeeTransfer :: Web3 () +priorityFeeTransfer = do + (payerPk, payerSk) <- fundedKeypair 2_000_000_000 + recipient <- fst <$> liftIO createSolanaKeyPair + sig <- + sendAndConfirm + [payerSk] + [ ComputeBudget.setComputeUnitLimit 20_000, + ComputeBudget.setComputeUnitPrice 1_000, + SystemProgram.transfer payerPk recipient 300_000_000 + ] + confirmFinalized sig + bal <- getBalance recipient + liftIO (bal @?= 300_000_000) + +-- | Smoke check only -- queries a fresh random pubkey with no fee history of +-- its own (the address list is just a filter passed to +-- 'Network.Solana.RPC.HTTP.Chain.getRecentPrioritizationFees', not a +-- dependency on 'priorityFeeTransfer'), and the estimate is +-- validator-dependent besides, so this asserts 'estimatePriorityFee' returns +-- without throwing rather than any particular value. +estimateSmoke :: Web3 () +estimateSmoke = do + pk <- fst <$> liftIO createSolanaKeyPair + fee <- estimatePriorityFee [pk] 0.5 + liftIO (fee `seq` pure ()) diff --git a/test-integration/Test/Integration/Setup.hs b/test-integration/Test/Integration/Setup.hs new file mode 100644 --- /dev/null +++ b/test-integration/Test/Integration/Setup.hs @@ -0,0 +1,184 @@ +-- | Shared plumbing for the local-validator integration suite. +-- +-- Every helper here runs against a real 'Web3' RPC connection (see 'run') +-- rather than fixtures, so tests built on top of this module only pass +-- against a live @solana-test-validator@ (or another reachable cluster). +-- +-- Commitment discipline: the node's default commitment is @finalized@, and +-- so is the default preflight commitment used for submitted transactions. +-- 'fundedKeypair' and 'fundedKeypairs' therefore finalize their airdrops +-- before returning (later sends preflight against the finalized bank), and +-- 'sendAndConfirm' (via 'sendConfirmedPreflight') pins preflight at +-- @confirmed@ so multi-step flows can build on merely-confirmed intermediate +-- state. Callers are expected to 'confirmFinalized' the last transaction of +-- a flow before asserting on account state or balances (finalization is +-- monotone by slot, so one wait covers every prior transaction). +module Test.Integration.Setup + ( rpcUrl, + wsEndpoint, + run, + fundedKeypair, + fundedKeypairs, + confirmOrFail, + confirmFinalized, + sendAndConfirm, + sendConfirmedPreflight, + requireJust, + ) +where + +import Control.Concurrent (threadDelay) +import Control.Exception (throwIO) +import Control.Monad.IO.Class (liftIO) +import Data.List (stripPrefix) +import Data.Maybe (fromMaybe) +import Network.Solana.Core.Account (Lamport) +import Network.Solana.Core.Crypto (SolanaPrivateKey, SolanaPublicKey, SolanaSignature, createSolanaKeyPair, toSolanaPublicKey) +import Network.Solana.Core.Instruction (Instruction) +import Network.Solana.Core.Message (newTransactionIntentWithPayer) +import Network.Solana.RPC.HTTP.Account (confirmationStatusTxStatus, errTxStatus, getSignatureStatuses) +import Network.Solana.RPC.HTTP.Block (getTheLatestBlockhash) +import Network.Solana.RPC.HTTP.Transaction (requestAirdrop, sendTransaction') +import Network.Solana.RPC.HTTP.Types (defaultConfigObject, encoding, preflightCommitment) +import Network.Solana.SolanaWeb3 (confirmTransaction) +import Network.Web3.Provider (Provider (HttpProvider), Web3, runWeb3') +import System.Environment (lookupEnv) + +-- | The RPC endpoint under test: @SOLANA_RPC_URL@ if set, otherwise the +-- default local validator address. +rpcUrl :: IO String +rpcUrl = fromMaybe "http://127.0.0.1:8899" <$> lookupEnv "SOLANA_RPC_URL" + +-- | The PubSub (WebSocket) endpoint matching 'rpcUrl' as host and port. +-- +-- Solana nodes serve PubSub on the RPC port plus one -- 8899 becomes 8900 -- +-- which is what @solana-test-validator@ does by default. +wsEndpoint :: IO (String, Int) +wsEndpoint = do + url <- rpcUrl + let authority = takeWhile (/= '/') (dropScheme url) + (host, rest) = break (== ':') authority + pure (host, rpcPort rest + 1) + where + dropScheme s + | Just rest <- stripPrefix "http://" s = rest + | Just rest <- stripPrefix "https://" s = rest + | otherwise = s + rpcPort (':' : digits) | [(p, "")] <- reads digits = p + rpcPort _ = 8899 + +-- | Runs a 'Web3' action against 'rpcUrl', throwing a 'userError' describing +-- the underlying 'Network.Web3.Provider.Web3Error' on RPC failure. +run :: Web3 a -> IO a +run action = do + url <- rpcUrl + result <- runWeb3' (HttpProvider url) action + either (throwIO . userError . ("web3 error: " <>) . show) pure result + +-- | Generates a fresh random keypair and airdrops it the given amount, +-- waiting for the airdrop to reach @finalized@ commitment before returning. +-- +-- Later sends preflight against the finalized bank, so funds must be +-- finalized before the first spend. +fundedKeypair :: Lamport -> Web3 (SolanaPublicKey, SolanaPrivateKey) +fundedKeypair amount = do + (pk, sk) <- liftIO createSolanaKeyPair + sig <- requestAirdrop pk amount + confirmFinalized sig + pure (pk, sk) + +-- | Generates fresh random keypairs and airdrops each the corresponding +-- amount. Airdrops are all requested before any is finalized, so the waits +-- for each signature overlap instead of running back-to-back. +fundedKeypairs :: [Lamport] -> Web3 [(SolanaPublicKey, SolanaPrivateKey)] +fundedKeypairs amounts = do + pairs <- liftIO (mapM (const createSolanaKeyPair) amounts) + sigs <- mapM (\(amount, (pk, _)) -> requestAirdrop pk amount) (zip amounts pairs) + mapM_ confirmFinalized sigs + pure pairs + +-- | Confirms the given signature with 'confirmTransaction' (reaches +-- @confirmed@ or @finalized@ with no on-chain error), throwing a 'userError' +-- naming the given label and the signature if it does not. +-- +-- 'confirmTransaction' returns 'False' both when the signature never reaches +-- the target commitment (e.g. it times out) and when it lands but fails +-- on-chain; on failure this re-reads 'getSignatureStatuses' to tell the two +-- apart, including the on-chain error in the message when there is one +-- (mirroring 'confirmFinalized'). +confirmOrFail :: String -> SolanaSignature -> Web3 () +confirmOrFail what sig = do + ok <- confirmTransaction sig + if ok + then pure () + else do + statuses <- getSignatureStatuses [sig] + case statuses of + [Just s] | Just err <- errTxStatus s -> + liftIO . throwIO . userError $ what <> " failed on-chain: " <> show sig <> ": " <> show err + _ -> liftIO . throwIO . userError $ what <> " failed to confirm: " <> show sig + +-- | Polls 'getSignatureStatuses' once a second, up to 60 times, until the +-- given signature reaches @finalized@ status. +-- +-- Throws a 'userError' if the transaction finalizes with an on-chain error, +-- or if it does not finalize within the poll budget (naming the signature in +-- both cases). +confirmFinalized :: SolanaSignature -> Web3 () +confirmFinalized sig = go (60 :: Int) + where + go 0 = liftIO . throwIO . userError $ "confirmFinalized: timed out waiting for finalization of " <> show sig + go n = do + statuses <- getSignatureStatuses [sig] + case statuses of + [Just s] | confirmationStatusTxStatus s == Just "finalized" -> + case errTxStatus s of + Nothing -> pure () + Just err -> liftIO . throwIO . userError $ "confirmFinalized: " <> show sig <> " failed on-chain: " <> show err + _ -> liftIO (threadDelay 1000000) >> go (n - 1) + +-- | Sends an already-encoded transaction with preflight pinned at +-- @confirmed@ -- the suite's one commitment override, single-sourced here so +-- every caller that must build/sign its own transaction (e.g. a v0 send +-- referencing an address lookup table, which 'sendAndConfirm' can't compile) +-- shares the same discipline instead of repeating the config literal. +-- +-- @confirmed@ multi-step flows build on merely-confirmed state; the node's +-- default preflight at @finalized@ would reject them. This also matters for +-- v0 sends specifically: an address added to a lookup table in slot @S@ only +-- resolves in a bank at a slot strictly greater than @S@ (see +-- 'Network.Solana.Core.VersionedMessage.compileV0Message'), and a +-- @finalized@-commitment preflight can simulate against a bank sitting +-- exactly at @S@ even after the extending transaction is itself finalized, +-- rejecting the send with \"Transaction address table lookup uses an +-- invalid index\". @confirmed@ preflight is not a general fix for that +-- invariant (see 'Network.Solana.Core.VersionedMessage.compileV0Message'); +-- it only works for this suite's flows because every caller of this +-- function that touches a lookup table (e.g. 'Test.Integration.Alt') first +-- 'confirmFinalized's the extend, which by then puts the confirmed bank +-- many slots past @S@. +sendConfirmedPreflight :: String -> Web3 SolanaSignature +sendConfirmedPreflight tx = sendTransaction' tx (defaultConfigObject {encoding = Just "base64", preflightCommitment = Just "confirmed"}) + +-- | Compiles the given signers and instructions with +-- 'newTransactionIntentWithPayer', naming the first signer as the fee payer +-- (forced writable regardless of what the given instructions themselves +-- declare -- plain 'newTransactionIntent' derives writability from the +-- instructions alone, which leaves the sole signer of an authority-only +-- instruction such as 'Network.Solana.SplPrograms.Token.mintTo' or +-- 'Network.Solana.SplPrograms.Token.transferChecked' non-writable, and every +-- Solana transaction requires its fee payer to be writable). Sends the +-- result with 'sendConfirmedPreflight', and confirms it with 'confirmOrFail'. +sendAndConfirm :: [SolanaPrivateKey] -> [Instruction] -> Web3 SolanaSignature +sendAndConfirm [] _ = liftIO (throwIO (userError "sendAndConfirm: no signers given")) +sendAndConfirm signers@(feePayer : _) ixs = do + bh <- getTheLatestBlockhash + tx <- either (liftIO . throwIO) pure (newTransactionIntentWithPayer (toSolanaPublicKey feePayer) signers ixs bh) + sig <- sendConfirmedPreflight tx + confirmOrFail "transaction" sig + pure sig + +-- | Unwraps a 'Just', throwing a 'userError' naming the given label if it is +-- 'Nothing'. +requireJust :: String -> Maybe a -> Web3 a +requireJust what = maybe (liftIO (throwIO (userError (what <> ": expected Just")))) pure diff --git a/test-integration/Test/Integration/Token.hs b/test-integration/Test/Integration/Token.hs new file mode 100644 --- /dev/null +++ b/test-integration/Test/Integration/Token.hs @@ -0,0 +1,53 @@ +-- | Live SPL token lifecycle coverage: create a mint, derive both parties' +-- associated token accounts, mint the initial supply, transfer part of it, +-- and check the decoded mint and token account state matches. +module Test.Integration.Token (tests) where + +import Control.Monad.IO.Class (liftIO) +import Network.Solana.Core.Crypto (createSolanaKeyPair) +import Network.Solana.NativePrograms.SystemProgram qualified as SystemProgram +import Network.Solana.RPC.HTTP.Tokenomics (getMinimumBalanceForRentExemption) +import Network.Solana.SolanaWeb3 (getMint, getTokenAccount) +import Network.Solana.SplPrograms.AssociatedTokenAccount qualified as ATA +import Network.Solana.SplPrograms.Token qualified as Token +import Network.Web3.Provider (Web3) +import Test.Integration.Setup +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "Token" + [testCase "mint -> ATAs -> mintTo -> transferChecked, decoded state matches" (run tokenLifecycle)] + +-- | Creates a mint (payer as mint authority, no freeze authority), derives +-- the associated token accounts for the payer and a second wallet, mints +-- the initial supply into the payer's ATA, transfers part of it to the +-- second wallet's ATA, and checks the decoded mint and both token accounts +-- reflect the expected supply, decimals, authority, balances, and owners. +tokenLifecycle :: Web3 () +tokenLifecycle = do + (payerPk, payerSk) <- fundedKeypair 3_000_000_000 + (mintPk, mintSk) <- liftIO createSolanaKeyPair + walletB <- fst <$> liftIO createSolanaKeyPair + mintRent <- getMinimumBalanceForRentExemption 82 + _ <- + sendAndConfirm + [payerSk, mintSk] + [ SystemProgram.createAccount payerPk mintPk mintRent 82 Token.tokenProgramId, + Token.initializeMint2 mintPk 6 payerPk Nothing + ] + ataA <- requireJust "ATA A derivation" (ATA.getAssociatedTokenAddress payerPk mintPk) + ataB <- requireJust "ATA B derivation" (ATA.getAssociatedTokenAddress walletB mintPk) + _ <- sendAndConfirm [payerSk] [ATA.createAssociatedTokenAccount payerPk payerPk mintPk] + _ <- sendAndConfirm [payerSk] [Token.mintTo mintPk ataA payerPk [] 1_000_000] + _ <- sendAndConfirm [payerSk] [ATA.createAssociatedTokenAccount payerPk walletB mintPk] + lastSig <- sendAndConfirm [payerSk] [Token.transferChecked ataA mintPk ataB payerPk [] 250_000 6] + confirmFinalized lastSig + mint <- requireJust "mint" =<< getMint mintPk + liftIO ((Token.mSupply mint @?= 1_000_000) >> (Token.mDecimals mint @?= 6) >> (Token.mMintAuthority mint @?= Just payerPk)) + accA <- requireJust "token account A" =<< getTokenAccount ataA + liftIO ((Token.taAmount accA @?= 750_000) >> (Token.taMint accA @?= mintPk) >> (Token.taOwner accA @?= payerPk)) + accB <- requireJust "token account B" =<< getTokenAccount ataB + liftIO ((Token.taAmount accB @?= 250_000) >> (Token.taOwner accB @?= walletB)) diff --git a/test-integration/Test/Integration/Transfer.hs b/test-integration/Test/Integration/Transfer.hs new file mode 100644 --- /dev/null +++ b/test-integration/Test/Integration/Transfer.hs @@ -0,0 +1,72 @@ +-- | Live SOL transfer coverage: a plain transfer from a freshly airdropped +-- payer, and a sponsored transfer where the fee payer and the transfer's +-- signer are different accounts. +module Test.Integration.Transfer (tests) where + +import Control.Exception (throwIO) +import Control.Monad (void) +import Control.Monad.IO.Class (liftIO) +import Network.Solana.Core.Crypto (createSolanaKeyPair) +import Network.Solana.Core.Message (newTransactionIntentWithPayer) +import Network.Solana.NativePrograms.SystemProgram qualified as SystemProgram +import Network.Solana.RPC.HTTP.Account (getBalance) +import Network.Solana.RPC.HTTP.Block (getTheLatestBlockhash) +import Network.Solana.RPC.HTTP.Chain (getVersion) +import Network.Solana.RPC.HTTP.Transaction (sendTransaction) +import Network.Solana.SolanaWeb3 (newTransaction) +import Network.Web3.Provider (Web3) +import Test.Integration.Setup +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "Transfer" + [ testCase "getVersion answers" (run (void getVersion)), + testCase "airdropped SOL transfer lands with the exact amount" (run basicTransfer), + testCase "sponsored transfer: sponsor pays the fee, signer order is free" (run sponsoredTransfer) + ] + +-- | Airdrops a payer, sends it through 'newTransaction' (which builds its +-- own blockhash and derives the fee payer from signer order), and checks the +-- recipient receives exactly the transferred amount. Live-covers +-- 'newTransaction' with every dependency (airdrop, blockhash, confirmation) +-- finalized. +basicTransfer :: Web3 () +basicTransfer = do + (payerPk, payerSk) <- fundedKeypair 2_000_000_000 + recipient <- fst <$> liftIO createSolanaKeyPair + sig <- newTransaction [payerSk] [SystemProgram.transfer payerPk recipient 1_000_000_000] + confirmFinalized sig + bal <- getBalance recipient + liftIO (bal @?= 1_000_000_000) + +-- | A sponsor pays the fee for a transfer sent by another funded account, with +-- the private keys deliberately passed in the wrong order to +-- 'newTransactionIntentWithPayer' -- its auto-ordering must still produce a +-- valid transaction. Checks that the recipient and sender balances reflect +-- only the transfer amount (the sender pays no fee) and that the sponsor's +-- balance dropped by more than the transfer (it paid the fee). +sponsoredTransfer :: Web3 () +sponsoredTransfer = do + pairs <- fundedKeypairs [2_000_000_000, 1_000_000_000] + ((sponsorPk, sponsorSk), (senderPk, senderSk)) <- case pairs of + [a, b] -> pure (a, b) + _ -> liftIO (throwIO (userError "expected two keypairs")) + recipient <- fst <$> liftIO createSolanaKeyPair + bh <- getTheLatestBlockhash + -- signers deliberately in the WRONG order: auto-ordering must fix it + tx <- + either + (liftIO . throwIO) + pure + (newTransactionIntentWithPayer sponsorPk [senderSk, sponsorSk] [SystemProgram.transfer senderPk recipient 500_000_000] bh) + sig <- sendTransaction tx + confirmFinalized sig + recipientBal <- getBalance recipient + liftIO (recipientBal @?= 500_000_000) + senderBal <- getBalance senderPk + liftIO (senderBal @?= 500_000_000) -- sender paid NO fee: exactly the transfer left + sponsorBal <- getBalance sponsorPk + liftIO (assertBool "sponsor paid the fee" (sponsorBal < 2_000_000_000)) diff --git a/test-integration/Test/Integration/WebSocket.hs b/test-integration/Test/Integration/WebSocket.hs new file mode 100644 --- /dev/null +++ b/test-integration/Test/Integration/WebSocket.hs @@ -0,0 +1,66 @@ +-- | Live PubSub coverage: confirm a real transaction by subscribing to its +-- signature over a WebSocket instead of polling for its status. +-- +-- This is also the worked example of wiring +-- 'Network.Solana.RPC.WebSocket.WsTransport' to the @websockets@ package, +-- which the SDK deliberately does not depend on (see that module's header). +module Test.Integration.WebSocket (tests) where + +import Control.Exception (throwIO) +import Control.Monad.IO.Class (liftIO) +import Network.Solana.Core.Crypto (SolanaPublicKey, SolanaSignature, createSolanaKeyPair) +import Network.Solana.Core.Message (newTransactionIntentWithPayer) +import Network.Solana.NativePrograms.SystemProgram qualified as SystemProgram +import Network.Solana.RPC.HTTP.Account (getBalance) +import Network.Solana.RPC.HTTP.Block (getTheLatestBlockhash) +import Network.Solana.RPC.WebSocket +import Network.Web3.Provider (Web3) +import Network.WebSockets qualified as WS +import Test.Integration.Setup +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "WebSocket" + [testCase "signature subscription pushes the confirmation" wsConfirmFlow] + +-- | Submits a transfer, then waits for its confirmation over the PubSub +-- endpoint rather than polling. +-- +-- The transaction is sent first and subscribed to immediately afterwards, at +-- @finalized@ commitment: finalization takes on the order of ten seconds even +-- on a local validator, so the subscription is established far in advance of +-- the notification it is waiting for. +wsConfirmFlow :: IO () +wsConfirmFlow = do + (recipient, sig) <- run submitTransfer + (host, port) <- wsEndpoint + result <- + WS.runClient host port "/" $ \conn -> + let transport = WsTransport (WS.sendTextData conn) (WS.receiveData conn) + in awaitSignature transport (RequestId 1) (Just "finalized") 90 sig + slot <- either assertFailure' pure result + assertBool "confirmation reports a real slot" (slot > 0) + balance <- run (getBalance recipient) + balance @?= 400_000_000 + +-- | Airdrops a payer and sends it a transfer, returning the recipient and the +-- submitted signature without waiting for confirmation -- that is what the +-- subscription is for. +submitTransfer :: Web3 (SolanaPublicKey, SolanaSignature) +submitTransfer = do + (payerPk, payerSk) <- fundedKeypair 2_000_000_000 + recipient <- fst <$> liftIO createSolanaKeyPair + bh <- getTheLatestBlockhash + tx <- + either + (liftIO . throwIO) + pure + (newTransactionIntentWithPayer payerPk [payerSk] [SystemProgram.transfer payerPk recipient 400_000_000] bh) + sig <- sendConfirmedPreflight tx + pure (recipient, sig) + +assertFailure' :: String -> IO a +assertFailure' = assertFailure diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,57 @@ +module Main (main) where + +import Test.Core.Account qualified +import Test.Core.Block qualified +import Test.Core.Borsh qualified +import Test.Core.Compact qualified +import Test.Core.Crypto qualified +import Test.Core.Instruction qualified +import Test.Core.Message qualified +import Test.Core.Pda qualified +import Test.Core.VersionedMessage qualified +import Test.Metaplex.TokenMetadata qualified +import Test.NativePrograms.AddressLookupTable qualified +import Test.NativePrograms.BpfLoaderUpgradeable qualified +import Test.NativePrograms.ComputeBudget qualified +import Test.NativePrograms.Secp256k1 qualified +import Test.NativePrograms.Stake qualified +import Test.NativePrograms.SystemProgram qualified +import Test.NativePrograms.Vote qualified +import Test.RPC.Chain qualified +import Test.RPC.Parsers qualified +import Test.RPC.WebSocket qualified +import Test.SplPrograms.AssociatedTokenAccount qualified +import Test.SplPrograms.Memo qualified +import Test.SplPrograms.Token qualified +import Test.Tasty + +main :: IO () +main = + defaultMain + ( testGroup + "solana-haskell-sdk" + [ Test.Core.Account.tests, + Test.Core.Block.tests, + Test.Core.Borsh.tests, + Test.Core.Compact.tests, + Test.Core.Crypto.tests, + Test.Core.Instruction.tests, + Test.Core.Message.tests, + Test.Core.Pda.tests, + Test.Core.VersionedMessage.tests, + Test.Metaplex.TokenMetadata.tests, + Test.NativePrograms.AddressLookupTable.tests, + Test.NativePrograms.BpfLoaderUpgradeable.tests, + Test.NativePrograms.ComputeBudget.tests, + Test.NativePrograms.Secp256k1.tests, + Test.NativePrograms.Stake.tests, + Test.NativePrograms.SystemProgram.tests, + Test.NativePrograms.Vote.tests, + Test.RPC.Chain.tests, + Test.RPC.Parsers.tests, + Test.RPC.WebSocket.tests, + Test.SplPrograms.AssociatedTokenAccount.tests, + Test.SplPrograms.Memo.tests, + Test.SplPrograms.Token.tests + ] + ) diff --git a/test/Test/Core/Account.hs b/test/Test/Core/Account.hs new file mode 100644 --- /dev/null +++ b/test/Test/Core/Account.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Core.Account (tests) where + +import Data.Aeson (eitherDecode) +import Network.Solana.Core.Account +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "account" + [ testCase "AccountData FromJSON rejects an unsupported encoding tag" $ + case eitherDecode "[\"abcd\",\"unknownEncoding\"]" :: Either String AccountData of + Left _ -> pure () + Right ad -> assertFailure ("expected parse failure, got " <> show ad), + testCase "AccountData FromJSON rejects invalid base58 in a base58-tagged pair" $ + case eitherDecode "[\"0OIl\",\"base58\"]" :: Either String AccountData of + Left _ -> pure () + Right ad -> assertFailure ("expected parse failure, got " <> show ad) + ] diff --git a/test/Test/Core/Block.hs b/test/Test/Core/Block.hs new file mode 100644 --- /dev/null +++ b/test/Test/Core/Block.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Core.Block (tests) where + +import Data.Aeson (eitherDecode) +import Data.Binary (decode, encode) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy.Char8 qualified as LC8 +import Network.Solana.Core.Block +import Network.Solana.Core.Crypto (toBase58String) +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "block" + [ testCase "BlockHash FromJSON rejects invalid base58" $ + case eitherDecode "\"0OIl\"" :: Either String BlockHash of + Left _ -> pure () + Right bh -> assertFailure ("expected parse failure, got " <> show bh), + testCase "BlockHash FromJSON rejects valid base58 of the wrong length" $ + let wrongLengthBase58 = toBase58String (BS.replicate 5 7) + json = LC8.pack (show wrongLengthBase58) + in case eitherDecode json :: Either String BlockHash of + Left _ -> pure () + Right bh -> assertFailure ("expected parse failure, got " <> show bh), + testCase "BlockHash Binary round-trip (32-byte hash)" $ + let bh = BlockHash (BS.replicate 32 7) + in decode (encode bh) @?= bh + ] diff --git a/test/Test/Core/Borsh.hs b/test/Test/Core/Borsh.hs new file mode 100644 --- /dev/null +++ b/test/Test/Core/Borsh.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Core.Borsh (tests) where + +import Data.Binary.Get (runGetOrFail) +import Data.Binary.Put (runPut) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BL +import Data.Maybe (isNothing) +import Network.Solana.Core.Borsh +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck as QC + +tests :: TestTree +tests = + testGroup + "borsh" + [ testGroup + "string" + [ testCase "putBorshString produces u32-prefixed UTF-8" $ + let bs = BL.toStrict (runPut (putBorshString "ab")) + expected = BS.pack [0x02, 0x00, 0x00, 0x00, 0x61, 0x62] + in bs @?= expected, + testCase "putBorshString counts UTF-8 bytes, not characters" $ + -- "é" is 1 character but 2 UTF-8 bytes (0xC3 0xA9); the u32 prefix + -- must be the byte length (2), not the char count (1). + let bs = BL.toStrict (runPut (putBorshString "é")) + expected = BS.pack [0x02, 0x00, 0x00, 0x00, 0xC3, 0xA9] + in bs @?= expected, + testCase "getBorshString decodes u32-prefixed UTF-8" $ + let bs = BS.pack [0x02, 0x00, 0x00, 0x00, 0x61, 0x62] + in case runGetOrFail getBorshString (BL.fromStrict bs) of + Right (_, _, s) -> s @?= "ab" + Left (_, _, err) -> assertFailure $ "getBorshString failed: " <> err, + testCase "getBorshString fails on invalid UTF-8" $ + let bs = BS.pack [0x02, 0x00, 0x00, 0x00, 0xFF, 0xFE] + in case runGetOrFail getBorshString (BL.fromStrict bs) of + Right (_, _, _) -> assertFailure "expected UTF-8 decode failure" + Left _ -> pure (), + QC.testProperty "string round-trip (ASCII)" $ \s -> + let printable = filter (\c -> c >= ' ' && c <= '~') s + bs = BL.toStrict (runPut (putBorshString printable)) + in case runGetOrFail getBorshString (BL.fromStrict bs) of + Right (_, _, decoded) -> decoded == printable + Left _ -> False + ], + testGroup + "option" + [ testCase "putBorshOption Nothing produces tag 0" $ + let bs = BL.toStrict (runPut (putBorshOption putBorshString Nothing)) + in bs @?= BS.pack [0x00], + testCase "putBorshOption Just encodes tag 1 + value" $ + let bs = BL.toStrict (runPut (putBorshOption putBorshString (Just "a"))) + -- Tag 1, then string "a": length 1 (u32 LE = 0x01 0x00 0x00 0x00), then 0x61 (a) + expected = BS.pack [0x01, 0x01, 0x00, 0x00, 0x00, 0x61] + in bs @?= expected, + testCase "getBorshOption decodes Nothing (tag 0)" $ + let bs = BS.pack [0x00] + in case runGetOrFail (getBorshOption getBorshString) (BL.fromStrict bs) of + Right (_, _, opt) -> opt @?= Nothing + Left (_, _, err) -> assertFailure $ "getBorshOption failed: " <> err, + testCase "getBorshOption decodes Just (tag 1)" $ + let bs = BS.pack [0x01, 0x01, 0x00, 0x00, 0x00, 0x61] + in case runGetOrFail (getBorshOption getBorshString) (BL.fromStrict bs) of + Right (_, _, opt) -> opt @?= Just "a" + Left (_, _, err) -> assertFailure $ "getBorshOption failed: " <> err, + testCase "getBorshOption fails on invalid tag (>1)" $ + let bs = BS.pack [0x02] + in case runGetOrFail (getBorshOption getBorshString) (BL.fromStrict bs) of + Right (_, _, _) -> assertFailure "expected tag validation failure" + Left _ -> pure (), + QC.testProperty "option round-trip (Nothing)" $ + let bs = BL.toStrict (runPut (putBorshOption putBorshString (Nothing :: Maybe String))) + in case runGetOrFail (getBorshOption getBorshString) (BL.fromStrict bs) of + Right (_, _, opt) -> isNothing opt + Left _ -> False, + QC.testProperty "option round-trip (Just)" $ \s -> + let printable = filter (\c -> c >= ' ' && c <= '~') s + bs = BL.toStrict (runPut (putBorshOption putBorshString (Just printable))) + in case runGetOrFail (getBorshOption getBorshString) (BL.fromStrict bs) of + Right (_, _, opt) -> opt == Just printable + Left _ -> False + ], + testGroup + "vec" + [ testCase "putBorshVec empty produces count 0" $ + let bs = BL.toStrict (runPut (putBorshVec putBorshBool [])) + in bs @?= BS.pack [0x00, 0x00, 0x00, 0x00], + testCase "putBorshVec encodes u32 count + elements" $ + let bs = BL.toStrict (runPut (putBorshVec putBorshBool [True, False])) + -- Count 2 (u32 LE = 0x02 0x00 0x00 0x00), then True (0x01), False (0x00) + expected = BS.pack [0x02, 0x00, 0x00, 0x00, 0x01, 0x00] + in bs @?= expected, + testCase "getBorshVec decodes empty list" $ + let bs = BS.pack [0x00, 0x00, 0x00, 0x00] + in case runGetOrFail (getBorshVec getBorshBool) (BL.fromStrict bs) of + Right (_, _, xs) -> xs @?= [] + Left (_, _, err) -> assertFailure $ "getBorshVec failed: " <> err, + testCase "getBorshVec decodes count + elements" $ + let bs = BS.pack [0x02, 0x00, 0x00, 0x00, 0x01, 0x00] + in case runGetOrFail (getBorshVec getBorshBool) (BL.fromStrict bs) of + Right (_, _, xs) -> xs @?= [True, False] + Left (_, _, err) -> assertFailure $ "getBorshVec failed: " <> err, + QC.testProperty "vec round-trip (bools)" $ \bs -> + let truncated = take 10 bs -- small list for reasonable test + putVec = runPut (putBorshVec putBorshBool truncated) + in case runGetOrFail (getBorshVec getBorshBool) putVec of + Right (_, _, decoded) -> decoded == truncated + Left _ -> False + ], + testGroup + "bool" + [ testCase "putBorshBool False produces 0x00" $ + let bs = BL.toStrict (runPut (putBorshBool False)) + in bs @?= BS.pack [0x00], + testCase "putBorshBool True produces 0x01" $ + let bs = BL.toStrict (runPut (putBorshBool True)) + in bs @?= BS.pack [0x01], + testCase "getBorshBool decodes False (0x00)" $ + let bs = BS.pack [0x00] + in case runGetOrFail getBorshBool (BL.fromStrict bs) of + Right (_, _, b) -> b @?= False + Left (_, _, err) -> assertFailure $ "getBorshBool failed: " <> err, + testCase "getBorshBool decodes True (0x01)" $ + let bs = BS.pack [0x01] + in case runGetOrFail getBorshBool (BL.fromStrict bs) of + Right (_, _, b) -> b @?= True + Left (_, _, err) -> assertFailure $ "getBorshBool failed: " <> err, + testCase "getBorshBool fails on invalid byte (2)" $ + let bs = BS.pack [0x02] + in case runGetOrFail getBorshBool (BL.fromStrict bs) of + Right (_, _, _) -> assertFailure "expected bool validation failure" + Left _ -> pure (), + testCase "getBorshBool fails on invalid byte (255)" $ + let bs = BS.pack [0xFF] + in case runGetOrFail getBorshBool (BL.fromStrict bs) of + Right (_, _, _) -> assertFailure "expected bool validation failure" + Left _ -> pure (), + QC.testProperty "bool round-trip" $ \b -> + let bs = BL.toStrict (runPut (putBorshBool b)) + in case runGetOrFail getBorshBool (BL.fromStrict bs) of + Right (_, _, decoded) -> decoded == b + Left _ -> False + ] + ] diff --git a/test/Test/Core/Compact.hs b/test/Test/Core/Compact.hs new file mode 100644 --- /dev/null +++ b/test/Test/Core/Compact.hs @@ -0,0 +1,44 @@ +module Test.Core.Compact (tests) where + +import Data.Binary (decode, encode) +import Data.ByteString.Lazy qualified as BL +import Data.Word (Word8) +import Network.Solana.Core.Compact +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +tests :: TestTree +tests = + testGroup + "compact-u16" + [ testCase "known encodings" $ do + BL.unpack (encodeCompactU16 0) @?= [0x00] + BL.unpack (encodeCompactU16 1) @?= [0x01] + BL.unpack (encodeCompactU16 127) @?= [0x7f] + BL.unpack (encodeCompactU16 128) @?= [0x80, 0x01] + BL.unpack (encodeCompactU16 16383) @?= [0xff, 0x7f] + BL.unpack (encodeCompactU16 16384) @?= [0x80, 0x80, 0x01] + BL.unpack (encodeCompactU16 65535) @?= [0xff, 0xff, 0x03], + testProperty "decode . encode == id" $ \w -> + decodeCompactU16 (encodeCompactU16 w) === Right w, + testProperty "encoded length matches value range" $ \w -> + let len = fromIntegral (BL.length (encodeCompactU16 w)) :: Int + in if w < 0x80 + then len === 1 + else + if w < 0x4000 + then len === 2 + else len === 3, + testCase "rejects overlong encoding" $ + assertLeft (decodeCompactU16 (BL.pack [0x80, 0x80, 0x80, 0x01])), + testCase "rejects aliased encoding" $ + assertLeft (decodeCompactU16 (BL.pack [0x80, 0x00])), + testProperty "CompactArray Binary decode . encode == id" $ + forAll (resize 500 (listOf arbitrary)) $ \(xs :: [Word8]) -> + let ca = mkCompact xs in decode (encode ca) === ca + ] + +assertLeft :: (Show b) => Either a b -> Assertion +assertLeft (Left _) = pure () +assertLeft (Right v) = assertFailure ("expected decode failure, got " <> show v) diff --git a/test/Test/Core/Crypto.hs b/test/Test/Core/Crypto.hs new file mode 100644 --- /dev/null +++ b/test/Test/Core/Crypto.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Core.Crypto (tests) where + +import Data.Aeson (eitherDecode) +import Data.Binary (decode, encode) +import Data.ByteString qualified as BS +import Network.Solana.Core.Crypto +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +newtype Bytes32 = Bytes32 BS.ByteString + deriving (Show) + +instance Arbitrary Bytes32 where + arbitrary = Bytes32 . BS.pack <$> vectorOf 32 arbitrary + +tests :: TestTree +tests = + testGroup + "crypto" + [ testProperty "base58 round-trip" $ \(Bytes32 bs) -> + fromBase58String (toBase58String bs) === Just bs, + testProperty "base64 round-trip" $ \(Bytes32 bs) -> + fromBase64String (toBase64String bs) === bs, + testProperty "public key Binary round-trip" $ \(Bytes32 bs) -> + let pk = unsafeSolanaPublicKeyRaw (BS.unpack bs) + in decode (encode pk) === pk, + testCase "signature Binary round-trip (64 bytes)" $ do + Just (_, priv) <- pure (createSolanaKeypairFromSeed (BS.replicate 32 1)) + let sig = dsign priv "solana-haskell-sdk" + decode (encode sig) @?= sig, + testCase "private key Base58 round-trip (64-byte NaCl secret key)" $ do + (_, priv) <- createSolanaKeyPair + case mkPrivateKeyFromString (show priv) of + Left err -> assertFailure ("mkPrivateKeyFromString failed on a genuine keypair: " <> err) + Right priv' -> do + show priv' @?= show priv + dsign priv' "solana-haskell-sdk" @?= dsign priv "solana-haskell-sdk", + testCase "SolanaPublicKey FromJSON rejects invalid base58" $ + case eitherDecode "\"0OIl\"" :: Either String SolanaPublicKey of + Left _ -> pure () + Right pk -> assertFailure ("expected parse failure, got " <> show pk), + testCase "SolanaSignature FromJSON rejects invalid base58" $ + case eitherDecode "\"0OIl\"" :: Either String SolanaSignature of + Left _ -> pure () + Right sig -> assertFailure ("expected parse failure, got " <> show sig) + ] diff --git a/test/Test/Core/Instruction.hs b/test/Test/Core/Instruction.hs new file mode 100644 --- /dev/null +++ b/test/Test/Core/Instruction.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Core.Instruction (tests) where + +import Data.Aeson (eitherDecode) +import Network.Solana.Core.Crypto (SolanaPublicKey, unsafeSolanaPublicKeyRaw) +import Network.Solana.Core.Instruction +import Test.Tasty +import Test.Tasty.HUnit + +progPk, accPk :: SolanaPublicKey +progPk = unsafeSolanaPublicKeyRaw (replicate 32 11) +accPk = unsafeSolanaPublicKeyRaw (replicate 32 12) + +tests :: TestTree +tests = + testGroup + "instruction" + [ testCase "mkInstruction keeps exactly the given account metas" $ do + let meta = AccountMeta {accountPubKey = accPk, isSigner = True, isWritable = True} + ix = mkInstruction progPk [meta] () + iAccounts ix @?= [meta] + iProgramId ix @?= progPk, + testCase "CompiledInstruction FromJSON rejects invalid base58 data" $ + case eitherDecode "{\"programIdIndex\":0,\"accounts\":[0,1],\"data\":\"0OIl\"}" :: Either String CompiledInstruction of + Left _ -> pure () + Right _ -> assertFailure "expected parse failure on invalid base58" + ] diff --git a/test/Test/Core/Message.hs b/test/Test/Core/Message.hs new file mode 100644 --- /dev/null +++ b/test/Test/Core/Message.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Core.Message (tests) where + +import Data.ByteString qualified as BS +import Data.List (isInfixOf, nub) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Set qualified as Set +import Network.Solana.Core.Block (BlockHash (..)) +import Network.Solana.Core.Crypto +import Network.Solana.Core.Instruction +import Network.Solana.Core.Message +import Network.Solana.NativePrograms.ComputeBudget qualified as CB +import Network.Solana.NativePrograms.Stake qualified as Stake +import Network.Solana.NativePrograms.SystemProgram qualified as SP +import Network.Solana.SplPrograms.AssociatedTokenAccount qualified as Ata +import Network.Solana.SplPrograms.Memo qualified as Memo +import Network.Solana.SplPrograms.Token qualified as Tok +import Test.Fixtures +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +fixedBlockhash :: BlockHash +fixedBlockhash = BlockHash (BS.replicate 32 9) + +recipientPk :: SolanaPublicKey +recipientPk = unsafeSolanaPublicKeyRaw (replicate 32 2) + +ownerPk :: SolanaPublicKey +ownerPk = unsafeSolanaPublicKeyRaw (replicate 32 5) + +votePk' :: SolanaPublicKey +votePk' = unsafeSolanaPublicKeyRaw (replicate 32 17) + +custodianPk' :: SolanaPublicKey +custodianPk' = unsafeSolanaPublicKeyRaw (replicate 32 18) + +payerKeys :: (SolanaPublicKey, SolanaPrivateKey) +payerKeys = + case createSolanaKeypairFromSeed (BS.replicate 32 1) of + Just kp -> kp + Nothing -> error "failed to derive payer keypair from seed" + +newAccountKeys :: (SolanaPublicKey, SolanaPrivateKey) +newAccountKeys = + case createSolanaKeypairFromSeed (BS.replicate 32 10) of + Just kp -> kp + Nothing -> error "failed to derive new-account keypair from seed" + +extraKeys :: (SolanaPublicKey, SolanaPrivateKey) +extraKeys = + case createSolanaKeypairFromSeed (BS.replicate 32 40) of + Just kp -> kp + Nothing -> error "failed to derive extra keypair from seed" + +keyPool :: [SolanaPublicKey] +keyPool = [unsafeSolanaPublicKeyRaw (replicate 32 b) | b <- [10 .. 15]] + +genInstruction :: Gen Instruction +genInstruction = do + progId <- elements keyPool + n <- chooseInt (1, 4) + metas <- vectorOf n genMeta + pure (mkInstruction progId metas ()) + where + genMeta = do + k <- elements keyPool + s <- arbitrary + w <- arbitrary + pure AccountMeta {accountPubKey = k, isSigner = s, isWritable = w} + +expectedPrivileges :: [Instruction] -> Map.Map SolanaPublicKey (Bool, Bool) +expectedPrivileges instrs = Map.fromListWith merge (concatMap entries instrs) + where + merge (s1, w1) (s2, w2) = (s1 || s2, w1 || w2) + entries i = + (iProgramId i, (False, False)) + : [(accountPubKey m, (isSigner m, isWritable m)) | m <- iAccounts i] + +prop_messageInvariants :: Property +prop_messageInvariants = + forAll (resize 5 (listOf1 genInstruction)) $ \instrs -> + let msg = mkNewMessage fixedBlockhash instrs + keys = mAccountKeys msg + privs = expectedPrivileges instrs + hdr = mHeader msg + nrs = fromIntegral (numRequiredSignatures hdr) + nros = fromIntegral (numReadonlySignedAccounts hdr) + nrou = fromIntegral (numReadonlyUnsignedAccounts hdr) + (signed, unsigned) = splitAt nrs keys + (sw, sr) = splitAt (nrs - nros) signed + (uw, ur) = splitAt (length unsigned - nrou) unsigned + signerOf k = maybe False fst (Map.lookup k privs) + writableOf k = maybe False snd (Map.lookup k privs) + in conjoin + [ counterexample "duplicate keys" (keys === nub keys), + counterexample "key set mismatch" (Map.keysSet privs === Set.fromList keys), + counterexample "non-signer in signed section" (property (all signerOf signed)), + counterexample "signer in unsigned section" (property (not (any signerOf unsigned))), + counterexample "readonly key in writable section" (property (all writableOf (sw <> uw))), + counterexample "writable key in readonly section" (property (not (any writableOf (sr <> ur)))) + ] + +tests :: TestTree +tests = + testGroup + "message and transaction (golden)" + [ testCase "payer pubkey from seed matches Rust" $ do + fs <- loadFixtures "test/fixtures/transactions.json" + getSolanaPublicKeyRaw (fst payerKeys) @?= requireFixture "payer-pubkey" fs, + testCase "single transfer message bytes match Rust" $ do + fs <- loadFixtures "test/fixtures/messages.json" + let ix = SP.transfer (fst payerKeys) recipientPk 1000000000 + case newMessage fixedBlockhash [ix] of + Left err -> assertFailure (show err) + Right bytes -> bytes @?= requireFixture "transfer-message" fs, + testCase "signed transfer transaction matches Rust" $ do + fs <- loadFixtures "test/fixtures/transactions.json" + let ix = SP.transfer (fst payerKeys) recipientPk 1000000000 + case newTransactionIntent [snd payerKeys] [ix] fixedBlockhash of + Left err -> assertFailure (show err) + Right b64 -> b64 @?= toBase64String (requireFixture "transfer-transaction" fs), + testCase "transfer + allocate message bytes match Rust" $ do + fs <- loadFixtures "test/fixtures/messages.json" + let transferIx = SP.transfer (fst payerKeys) recipientPk 1000000000 + allocateIx = SP.allocate (fst payerKeys) 200 + case newMessage fixedBlockhash [transferIx, allocateIx] of + Left err -> assertFailure (show err) + Right bytes -> bytes @?= requireFixture "transfer-allocate-message" fs, + testCase "priority-fee transaction matches Rust" $ do + fs <- loadFixtures "test/fixtures/transactions.json" + let ixs = + [ CB.setComputeUnitLimit 200000, + CB.setComputeUnitPrice 1000, + SP.transfer (fst payerKeys) recipientPk 1000000000, + Memo.buildMemo "hello-memo" [fst payerKeys] + ] + case newTransactionIntent [snd payerKeys] ixs fixedBlockhash of + Left err -> assertFailure (show err) + Right b64 -> b64 @?= toBase64String (requireFixture "priority-transfer-transaction" fs), + testCase "new-account pubkey from seed matches Rust" $ do + fs <- loadFixtures "test/fixtures/transactions.json" + getSolanaPublicKeyRaw (fst newAccountKeys) @?= requireFixture "new-account-pubkey" fs, + testCase "two-signer create-account transaction matches Rust (payer pinned, not sorted)" $ do + fs <- loadFixtures "test/fixtures/transactions.json" + let ix = SP.createAccount (fst payerKeys) (fst newAccountKeys) 1000000 165 ownerPk + case newTransactionIntent [snd payerKeys, snd newAccountKeys] [ix] fixedBlockhash of + Left err -> assertFailure (show err) + Right b64 -> b64 @?= toBase64String (requireFixture "two-signer-create-transaction" fs), + testCase "ATA create + transferChecked transaction matches Rust" $ do + fs <- loadFixtures "test/fixtures/transactions.json" + let mintPk = unsafeSolanaPublicKeyRaw (replicate 32 12) + walletPk = unsafeSolanaPublicKeyRaw (replicate 32 11) + payerPk = fst payerKeys + srcAta = fromMaybe (error "no src ata") (Ata.getAssociatedTokenAddress payerPk mintPk) + dstAta = fromMaybe (error "no dst ata") (Ata.getAssociatedTokenAddress walletPk mintPk) + ixs = + [ Ata.createAssociatedTokenAccountIdempotent payerPk walletPk mintPk, + Tok.transferChecked srcAta mintPk dstAta payerPk [] 1000000 6 + ] + case newTransactionIntent [snd payerKeys] ixs fixedBlockhash of + Left err -> assertFailure (show err) + Right b64 -> b64 @?= toBase64String (requireFixture "ata-transfer-transaction" fs), + testCase "stake setup transaction matches Rust" $ do + fs <- loadFixtures "test/fixtures/transactions.json" + let stakePk = fst newAccountKeys + authorized = Stake.Authorized {Stake.aStaker = fst payerKeys, Stake.aWithdrawer = fst payerKeys} + lockup = Stake.Lockup {Stake.lUnixTimestamp = 1700000000, Stake.lEpoch = 300, Stake.lCustodian = custodianPk'} + ixs = + [ SP.createAccount (fst payerKeys) stakePk 1000000 200 Stake.stakeProgramId, + Stake.initialize stakePk authorized lockup, + Stake.delegateStake stakePk (fst payerKeys) votePk' + ] + case newTransactionIntent [snd payerKeys, snd newAccountKeys] ixs fixedBlockhash of + Left err -> assertFailure (show err) + Right b64 -> b64 @?= toBase64String (requireFixture "stake-setup-transaction" fs), + testCase "sponsored transfer via explicit fee payer matches Rust (signers in wrong order)" $ do + fs <- loadFixtures "test/fixtures/transactions.json" + let ix = SP.transfer (fst payerKeys) recipientPk 1000000000 + case newTransactionIntentWithPayer (fst newAccountKeys) [snd payerKeys, snd newAccountKeys] [ix] fixedBlockhash of + Left err -> assertFailure (show err) + Right b64 -> b64 @?= toBase64String (requireFixture "sponsored-transfer-transaction" fs), + testCase "sponsored transfer via explicit fee payer matches Rust (signers in message order)" $ do + fs <- loadFixtures "test/fixtures/transactions.json" + let ix = SP.transfer (fst payerKeys) recipientPk 1000000000 + case newTransactionIntentWithPayer (fst newAccountKeys) [snd newAccountKeys, snd payerKeys] [ix] fixedBlockhash of + Left err -> assertFailure (show err) + Right b64 -> b64 @?= toBase64String (requireFixture "sponsored-transfer-transaction" fs), + testCase "two-signer create-account via explicit fee payer matches Rust (signers permuted)" $ do + fs <- loadFixtures "test/fixtures/transactions.json" + let ix = SP.createAccount (fst payerKeys) (fst newAccountKeys) 1000000 165 ownerPk + case newTransactionIntentWithPayer (fst payerKeys) [snd newAccountKeys, snd payerKeys] [ix] fixedBlockhash of + Left err -> assertFailure (show err) + Right b64 -> b64 @?= toBase64String (requireFixture "two-signer-create-transaction" fs), + testCase "explicit fee payer: missing signer key is reported" $ do + let ix = SP.transfer (fst payerKeys) recipientPk 1000000000 + case newTransactionIntentWithPayer (fst newAccountKeys) [snd payerKeys] [ix] fixedBlockhash of + Right _ -> assertFailure "expected Left for missing signer" + Left (MissingIndex msg) -> assertBool ("expected \"missing signer\" in: " <> msg) ("missing signer" `isInfixOf` msg), + testCase "explicit fee payer: unused signing key is reported" $ do + let ix = SP.transfer (fst payerKeys) recipientPk 1000000000 + case newTransactionIntentWithPayer (fst newAccountKeys) [snd payerKeys, snd newAccountKeys, snd extraKeys] [ix] fixedBlockhash of + Right _ -> assertFailure "expected Left for unused signing key" + Left (MissingIndex msg) -> assertBool ("expected \"unused signing key\" in: " <> msg) ("unused signing key" `isInfixOf` msg), + testCase "durable-nonce transfer transaction matches Rust" $ do + txFs <- loadFixtures "test/fixtures/transactions.json" + stateFs <- loadFixtures "test/fixtures/state_fixtures.json" + let noncePk = unsafeSolanaPublicKeyRaw (replicate 32 37) + durableNonceBh = BlockHash (requireFixture "nonce-durable-hash" stateFs) + ix = SP.transfer (fst payerKeys) recipientPk 1000000000 + case newDurableNonceTransactionIntent [snd payerKeys] noncePk (fst payerKeys) [ix] durableNonceBh of + Left err -> assertFailure (show err) + Right b64 -> b64 @?= toBase64String (requireFixture "nonce-transfer-transaction" txFs), + testCase "durable-nonce transfer via explicit fee payer matches Rust (payer == authority)" $ do + txFs <- loadFixtures "test/fixtures/transactions.json" + stateFs <- loadFixtures "test/fixtures/state_fixtures.json" + let noncePk = unsafeSolanaPublicKeyRaw (replicate 32 37) + durableNonceBh = BlockHash (requireFixture "nonce-durable-hash" stateFs) + ix = SP.transfer (fst payerKeys) recipientPk 1000000000 + case newDurableNonceTransactionIntentWithPayer (fst payerKeys) [snd payerKeys] noncePk (fst payerKeys) [ix] durableNonceBh of + Left err -> assertFailure (show err) + Right b64 -> b64 @?= toBase64String (requireFixture "nonce-transfer-transaction" txFs), + testCase "durable-nonce-only message via explicit fee payer seeds payer as writable signer" $ do + stateFs <- loadFixtures "test/fixtures/state_fixtures.json" + let noncePk = unsafeSolanaPublicKeyRaw (replicate 32 37) + durableNonceBh = BlockHash (requireFixture "nonce-durable-hash" stateFs) + sponsorPk = fst newAccountKeys + sponsorPriv = snd newAccountKeys + authorityPk = fst payerKeys + authorityPriv = snd payerKeys + case newDurableNonceTransactionIntentWithPayer sponsorPk [sponsorPriv, authorityPriv] noncePk authorityPk [] durableNonceBh of + Left err -> assertFailure (show err) + Right b64 -> BS.head (fromBase64String b64) @?= 2, + testProperty "message header/key-ordering invariants" prop_messageInvariants + ] diff --git a/test/Test/Core/Pda.hs b/test/Test/Core/Pda.hs new file mode 100644 --- /dev/null +++ b/test/Test/Core/Pda.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Core.Pda (tests) where + +import Data.ByteString qualified as BS +import Data.Either (isLeft) +import Network.Solana.Core.Crypto (SolanaPublicKey, getSolanaPublicKeyRaw, unsafeSolanaPublicKey) +import Network.Solana.Core.Pda +import Test.Fixtures +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +tokenProgram :: SolanaPublicKey +tokenProgram = unsafeSolanaPublicKey "TokenkegQfeZyiNwAJbNbGKPFXCWuBvf9Ss623VQ5DA" + +tests :: TestTree +tests = + withResource (loadFixtures "test/fixtures/pda.json") (const (pure ())) $ \getFixtures -> + testGroup + "PDA derivation" + [ testCase "findProgramAddress matches Rust (address and bump)" $ do + fs <- getFixtures + case findProgramAddress ["solana-haskell-sdk/1"] tokenProgram of + Nothing -> assertFailure "no PDA found" + Just (addr, bump) -> do + getSolanaPublicKeyRaw addr @?= requireFixture "generic-pda-address" fs + BS.singleton bump @?= requireFixture "generic-pda-bump" fs, + testCase "seed longer than 32 bytes is rejected" $ + assertBool "expected Left" (isLeft (createProgramAddress [BS.replicate 33 0] tokenProgram)), + testProperty "createProgramAddress never returns an on-curve address" $ + forAll (BS.pack <$> vectorOf 8 arbitrary) $ \seed -> + case createProgramAddress [seed, "bump"] tokenProgram of + Left _ -> property True + Right addr -> property (getSolanaPublicKeyRaw addr /= BS.replicate 32 0) + ] diff --git a/test/Test/Core/VersionedMessage.hs b/test/Test/Core/VersionedMessage.hs new file mode 100644 --- /dev/null +++ b/test/Test/Core/VersionedMessage.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Core.VersionedMessage (tests) where + +import Data.ByteString qualified as BS +import Data.List (isInfixOf) +import Network.Solana.Core.Block (BlockHash (..)) +import Network.Solana.Core.Crypto +import Network.Solana.Core.Instruction (AccountMeta (..), CompileException (..), mkInstruction) +import Network.Solana.Core.VersionedMessage +import Network.Solana.NativePrograms.AddressLookupTable qualified as ALT +import Network.Solana.NativePrograms.SystemProgram qualified as SP +import Test.Fixtures +import Test.Tasty +import Test.Tasty.HUnit + +fixedBlockhash :: BlockHash +fixedBlockhash = BlockHash (BS.replicate 32 9) + +payerKeys :: (SolanaPublicKey, SolanaPrivateKey) +payerKeys = + case createSolanaKeypairFromSeed (BS.replicate 32 1) of + Just kp -> kp + Nothing -> error "failed to derive payer keypair from seed" + +recipientPk :: SolanaPublicKey +recipientPk = unsafeSolanaPublicKeyRaw (replicate 32 2) + +addr29 :: SolanaPublicKey +addr29 = unsafeSolanaPublicKeyRaw (replicate 32 29) + +addr30 :: SolanaPublicKey +addr30 = unsafeSolanaPublicKeyRaw (replicate 32 30) + +tableKey :: SolanaPublicKey +tableKey = unsafeSolanaPublicKeyRaw (replicate 32 31) + +unrelatedKey :: SolanaPublicKey +unrelatedKey = unsafeSolanaPublicKeyRaw (replicate 32 99) + +otherTableKey :: SolanaPublicKey +otherTableKey = unsafeSolanaPublicKeyRaw (replicate 32 33) + +dummyProgramId :: SolanaPublicKey +dummyProgramId = unsafeSolanaPublicKeyRaw (replicate 32 40) + +keyK :: SolanaPublicKey +keyK = unsafeSolanaPublicKeyRaw (replicate 32 41) + +fillerKey :: SolanaPublicKey +fillerKey = unsafeSolanaPublicKeyRaw (replicate 32 50) + +lookupTable :: AddressLookupTableAccount +lookupTable = AddressLookupTableAccount tableKey [recipientPk, addr29, addr30] + +tests :: TestTree +tests = + testGroup + "v0 message compilation (golden + behavior)" + [ testCase "v0 message bytes match Rust" $ do + fs <- loadFixtures "test/fixtures/transactions.json" + let ixs = + [ SP.transfer (fst payerKeys) recipientPk 1000000000, + SP.transfer (fst payerKeys) addr29 500000 + ] + case compileV0Message fixedBlockhash ixs [lookupTable] of + Left err -> assertFailure (show err) + Right bytes -> bytes @?= requireFixture "v0-message" fs, + testCase "v0 signed transaction matches Rust" $ do + fs <- loadFixtures "test/fixtures/transactions.json" + let ixs = + [ SP.transfer (fst payerKeys) recipientPk 1000000000, + SP.transfer (fst payerKeys) addr29 500000 + ] + case newV0TransactionIntent [snd payerKeys] ixs [lookupTable] fixedBlockhash of + Left err -> assertFailure (show err) + Right b64 -> b64 @?= toBase64String (requireFixture "v0-transfer-transaction" fs), + testCase "table containing only the program id yields no lookups" $ do + let ix = SP.transfer (fst payerKeys) recipientPk 1000000000 + table = AddressLookupTableAccount tableKey [SP.systemProgramId] + assertSameCompile + (compileV0Message fixedBlockhash [ix] [table]) + (compileV0Message fixedBlockhash [ix] []), + testCase "table containing the fee payer (a signer) yields no lookups" $ do + let ix = SP.transfer (fst payerKeys) recipientPk 1000000000 + table = AddressLookupTableAccount tableKey [fst payerKeys] + assertSameCompile + (compileV0Message fixedBlockhash [ix] [table]) + (compileV0Message fixedBlockhash [ix] []), + testCase "table with no keys used by the instructions yields no lookups" $ do + let ix = SP.transfer (fst payerKeys) recipientPk 1000000000 + table = AddressLookupTableAccount tableKey [unrelatedKey] + assertSameCompile + (compileV0Message fixedBlockhash [ix] [table]) + (compileV0Message fixedBlockhash [ix] []), + testCase "a key readonly in one instruction and writable in another drains as writable" $ do + let payerPk = fst payerKeys + ixReadonly = + mkInstruction + dummyProgramId + [AccountMeta payerPk True True, AccountMeta keyK False False] + () + ixWritable = + mkInstruction + dummyProgramId + [AccountMeta payerPk True True, AccountMeta keyK False True] + () + table = AddressLookupTableAccount tableKey [keyK] + assertSameCompile + (compileV0Message fixedBlockhash [ixReadonly, ixWritable] [table]) + (compileV0Message fixedBlockhash [ixWritable, ixWritable] [table]), + testCase "the first table containing a key wins over a later one" $ do + let ix = SP.transfer (fst payerKeys) recipientPk 1000000000 + table1 = AddressLookupTableAccount tableKey [recipientPk] + table2 = AddressLookupTableAccount otherTableKey [recipientPk] + assertSameCompile + (compileV0Message fixedBlockhash [ix] [table1, table2]) + (compileV0Message fixedBlockhash [ix] [table1]), + testCase "a lookup index beyond byte range fails to compile" $ do + let ix = SP.transfer (fst payerKeys) recipientPk 1000000000 + -- 256 filler addresses (indexes 0..255) push recipientPk to + -- index 256, one past what a Word8 lookup index can hold. + oversizedTable = AddressLookupTableAccount tableKey (replicate 256 fillerKey <> [recipientPk]) + case compileV0Message fixedBlockhash [ix] [oversizedTable] of + Left (MissingIndex msg) -> assertBool ("expected an \"overflow\" message, got: " <> msg) ("overflow" `isInfixOf` msg) + Right _ -> assertFailure "expected an oversized lookup table to fail compilation", + testCase "decoded lookup table state feeds v0 compilation end-to-end (bridge)" $ do + stateFs <- loadFixtures "test/fixtures/state_fixtures.json" + txFs <- loadFixtures "test/fixtures/transactions.json" + case ALT.decodeLookupTable (requireFixture "lookup-table" stateFs) of + Left err -> assertFailure ("decode failed: " <> err) + Right lts -> do + let table = ALT.lookupTableToAccount tableKey lts + ixs = + [ SP.transfer (fst payerKeys) recipientPk 1000000000, + SP.transfer (fst payerKeys) addr29 500000 + ] + case compileV0Message fixedBlockhash ixs [table] of + Left err -> assertFailure (show err) + Right bytes -> bytes @?= requireFixture "v0-message" txFs + ] + +-- | Compare two compile results by their message bytes ('CompileException' +-- has no 'Eq' instance to compare), failing loudly if either side failed. +assertSameCompile :: Either CompileException BS.ByteString -> Either CompileException BS.ByteString -> Assertion +assertSameCompile lhs rhs = case (lhs, rhs) of + (Right l, Right r) -> l @?= r + (Left err, _) -> assertFailure ("left side failed: " <> show err) + (_, Left err) -> assertFailure ("right side failed: " <> show err) diff --git a/test/Test/Fixtures.hs b/test/Test/Fixtures.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Fixtures + ( Fixture (..), + loadFixtures, + requireFixture, + RpcFixture (..), + loadRpcFixtures, + requireRpcResult, + ) +where + +import Data.Aeson +import Data.Aeson.Types (parseEither) +import Data.ByteString qualified as BS +import Data.ByteString.Base16 qualified as B16 +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE + +data Fixture = Fixture + { fixtureName :: String, + fixtureHex :: T.Text + } + deriving (Show) + +instance FromJSON Fixture where + parseJSON = withObject "Fixture" $ \v -> + Fixture <$> v .: "name" <*> v .: "hex" + +loadFixtures :: FilePath -> IO [Fixture] +loadFixtures path = either fail pure =<< eitherDecodeFileStrict path + +requireFixture :: String -> [Fixture] -> BS.ByteString +requireFixture name fs = + case filter ((== name) . fixtureName) fs of + [f] -> either (error . badHex) id (B16.decode (TE.encodeUtf8 (fixtureHex f))) + _ -> error ("fixture not found (or duplicated): " <> name) + where + badHex err = "bad hex in fixture " <> name <> ": " <> err + +-- | One recorded JSON-RPC exchange: the whole response envelope a real node +-- returned, as captured by @tools/rpc-record/record.py@. +data RpcFixture = RpcFixture + { rpcFixtureName :: String, + rpcFixtureMethod :: String, + rpcFixtureResponse :: Value + } + deriving (Show) + +instance FromJSON RpcFixture where + parseJSON = withObject "RpcFixture" $ \v -> + RpcFixture <$> v .: "name" <*> v .: "method" <*> v .: "response" + +loadRpcFixtures :: FilePath -> IO [RpcFixture] +loadRpcFixtures path = either fail pure =<< eitherDecodeFileStrict path + +-- | The @result@ payload of a recorded response -- what the SDK's parsers +-- actually receive, the JSON-RPC envelope having been stripped by the +-- transport. +requireRpcResult :: String -> [RpcFixture] -> Value +requireRpcResult name fs = + case filter ((== name) . rpcFixtureName) fs of + [f] -> either (error . badResult) id (parseEither (withObject "response" (.: "result")) (rpcFixtureResponse f)) + _ -> error ("rpc fixture not found (or duplicated): " <> name) + where + badResult err = "no result in rpc fixture " <> name <> ": " <> err diff --git a/test/Test/Metaplex/TokenMetadata.hs b/test/Test/Metaplex/TokenMetadata.hs new file mode 100644 --- /dev/null +++ b/test/Test/Metaplex/TokenMetadata.hs @@ -0,0 +1,301 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Metaplex.TokenMetadata (tests) where + +import Data.Aeson (FromJSON (..), Value, eitherDecodeFileStrict, withObject, (.:)) +import Data.Aeson.Types (parseMaybe) +import Data.Binary (decode, decodeOrFail, encode) +import Data.Binary.Get (ByteOffset) +import Data.ByteString qualified as BS +import Data.ByteString.Base16 qualified as B16 +import Data.ByteString.Lazy qualified as BL +import Data.List (find, isInfixOf) +import Data.Maybe (mapMaybe) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Network.Solana.Core.Crypto (SolanaPublicKey, createSolanaKeypairFromSeed, getSolanaPublicKeyRaw, unsafeSolanaPublicKeyRaw) +import Network.Solana.Core.Instruction (AccountMeta (..), iAccounts) +import Network.Solana.Metaplex.TokenMetadata qualified as TM +import Network.Solana.NativePrograms.SystemProgram qualified as SystemProgram +import Network.Solana.SplPrograms.Token qualified as Token +import Network.Solana.Sysvar qualified as Sysvar +import Test.Fixtures +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +-- Fixed constants (ratified in Task 1 against the mpl-token-metadata crate). + +mintPk :: SolanaPublicKey +mintPk = unsafeSolanaPublicKeyRaw (replicate 32 12) + +payerPk :: SolanaPublicKey +payerPk = + case createSolanaKeypairFromSeed (BS.replicate 32 1) of + Just (pk, _) -> pk + Nothing -> error "failed to derive payer" + +secondCreatorPk :: SolanaPublicKey +secondCreatorPk = unsafeSolanaPublicKeyRaw (replicate 32 33) + +collectionKeyPk :: SolanaPublicKey +collectionKeyPk = unsafeSolanaPublicKeyRaw (replicate 32 34) + +dataV2Full :: TM.DataV2 +dataV2Full = + TM.DataV2 + { TM.dName = "Solana Haskell NFT", + TM.dSymbol = "SHSDK", + TM.dUri = "https://example.com/nft.json", + TM.dSellerFeeBasisPoints = 550, + TM.dCreators = Just [TM.Creator payerPk True 60, TM.Creator secondCreatorPk False 40], + TM.dCollection = Just (TM.Collection False collectionKeyPk), + TM.dUses = Just (TM.Uses TM.Multiple 10 10) + } + +dataV2Minimal :: TM.DataV2 +dataV2Minimal = + TM.DataV2 + { TM.dName = "Solana Haskell NFT", + TM.dSymbol = "SHSDK", + TM.dUri = "https://example.com/nft.json", + TM.dSellerFeeBasisPoints = 550, + TM.dCreators = Nothing, + TM.dCollection = Nothing, + TM.dUses = Nothing + } + +-- metadata_instruction_data.json mixes two shapes in one array: six +-- {name, hex} entries (the golden vectors) and one {name, accounts} entry +-- (create-v3-full-accounts). Test.Fixtures.loadFixtures decodes the whole +-- file as [Fixture], which requires every element to carry a "hex" field, so +-- it can't be used directly here. Load the file as [Value] instead and pick +-- out each shape locally, without extending the shared loader. + +-- | Like 'loadFixtures', but tolerant of the extra {name, accounts} entry: +-- elements that don't parse as a {name, hex} 'Fixture' are simply skipped. +loadDataFixtures :: FilePath -> IO [Fixture] +loadDataFixtures path = do + vals <- either fail pure =<< eitherDecodeFileStrict path + pure (mapMaybe (parseMaybe parseJSON) (vals :: [Value])) + +-- Local decode of the `create-v3-full-accounts` entry (ground truth for the +-- createMetadataAccountV3 meta test). + +data FixtureAccountMeta = FixtureAccountMeta T.Text Bool Bool + +instance FromJSON FixtureAccountMeta where + parseJSON = withObject "FixtureAccountMeta" $ \v -> + FixtureAccountMeta <$> v .: "pubkey" <*> v .: "signer" <*> v .: "writable" + +data AccountsFixture = AccountsFixture + { afName :: String, + afAccounts :: [FixtureAccountMeta] + } + +instance FromJSON AccountsFixture where + parseJSON = withObject "AccountsFixture" $ \v -> + AccountsFixture <$> v .: "name" <*> v .: "accounts" + +loadCreateV3FullAccounts :: FilePath -> IO [AccountMeta] +loadCreateV3FullAccounts path = do + vals <- either fail pure =<< eitherDecodeFileStrict path + case find ((== "create-v3-full-accounts") . afName) (mapMaybe (parseMaybe parseJSON) (vals :: [Value])) of + Just af -> pure (map toAccountMeta (afAccounts af)) + Nothing -> fail "create-v3-full-accounts entry not found" + where + toAccountMeta (FixtureAccountMeta hexPubkey signer writable) = + AccountMeta + { accountPubKey = unsafeSolanaPublicKeyRaw (BS.unpack (decodeHex hexPubkey)), + isSigner = signer, + isWritable = writable + } + decodeHex hexPubkey = either (error . ("bad hex in create-v3-full-accounts: " <>)) id (B16.decode (TE.encodeUtf8 hexPubkey)) + +-- Small QuickCheck generators covering every support type and instruction +-- variant, for the round-trip property below. + +genPk :: Gen SolanaPublicKey +genPk = unsafeSolanaPublicKeyRaw <$> vectorOf 32 arbitrary + +genAsciiString :: Gen String +genAsciiString = listOf (elements ['a' .. 'z']) + +genUseMethod :: Gen TM.UseMethod +genUseMethod = elements [TM.Burn, TM.Multiple, TM.Single] + +genCreator :: Gen TM.Creator +genCreator = TM.Creator <$> genPk <*> arbitrary <*> arbitrary + +genCollection :: Gen TM.Collection +genCollection = TM.Collection <$> arbitrary <*> genPk + +genUses :: Gen TM.Uses +genUses = TM.Uses <$> genUseMethod <*> arbitrary <*> arbitrary + +genCollectionDetails :: Gen TM.CollectionDetails +genCollectionDetails = TM.CollectionDetailsV1 <$> arbitrary + +genMaybe :: Gen a -> Gen (Maybe a) +genMaybe g = oneof [pure Nothing, Just <$> g] + +genDataV2 :: Gen TM.DataV2 +genDataV2 = + TM.DataV2 + <$> genAsciiString + <*> genAsciiString + <*> genAsciiString + <*> arbitrary + <*> genMaybe (resize 3 (listOf genCreator)) + <*> genMaybe genCollection + <*> genMaybe genUses + +genTokenMetadataInstruction :: Gen TM.TokenMetadataInstruction +genTokenMetadataInstruction = + oneof + [ TM.CreateMetadataAccountV3 <$> genDataV2 <*> arbitrary <*> genMaybe genCollectionDetails, + TM.UpdateMetadataAccountV2 + <$> genMaybe genDataV2 + <*> genMaybe genPk + <*> genMaybe arbitrary + <*> genMaybe arbitrary, + TM.CreateMasterEditionV3 <$> genMaybe arbitrary + ] + +enc :: TM.TokenMetadataInstruction -> BS.ByteString +enc = BL.toStrict . encode + +tests :: TestTree +tests = + withResource (loadDataFixtures "test/fixtures/metadata_instruction_data.json") (const (pure ())) $ \getFixtures -> + withResource (loadFixtures "test/fixtures/pda.json") (const (pure ())) $ \getPdaFixtures -> + withResource (loadCreateV3FullAccounts "test/fixtures/metadata_instruction_data.json") (const (pure ())) $ \getCreateV3Accounts -> + withResource (loadFixtures "test/fixtures/state_fixtures.json") (const (pure ())) $ \getStateFixtures -> + testGroup + "Metaplex Token Metadata" + [ testGroup + "Metadata account state (golden + rejection)" + [ testCase "decodeMetadata: metadata-account golden (full tail)" $ do + fs <- getStateFixtures + let bs = requireFixture "metadata-account" fs + case TM.decodeMetadata bs of + Left err -> assertFailure $ "decode failed: " <> err + Right md -> do + TM.mdKey md @?= 4 + TM.mdUpdateAuthority md @?= payerPk + TM.mdMint md @?= mintPk + TM.mdName md @?= "Solana Haskell NFT" + TM.mdSymbol md @?= "SHSDK" + TM.mdUri md @?= "https://example.com/nft.json" + TM.mdSellerFeeBasisPoints md @?= 550 + TM.mdCreators md @?= Just [TM.Creator payerPk True 60, TM.Creator secondCreatorPk False 40] + TM.mdPrimarySaleHappened md @?= False + TM.mdIsMutable md @?= True + TM.mdEditionNonce md @?= Just 253 + TM.mdTokenStandard md @?= Just 0 + TM.mdCollection md @?= Just (TM.Collection False collectionKeyPk) + TM.mdUses md @?= Just (TM.Uses TM.Multiple 10 10), + testCase "decodeMetadata: metadata-account-legacy golden (empty tail)" $ do + fs <- getStateFixtures + let bs = requireFixture "metadata-account-legacy" fs + case TM.decodeMetadata bs of + Left err -> assertFailure $ "decode failed: " <> err + Right md -> do + TM.mdKey md @?= 4 + TM.mdUpdateAuthority md @?= payerPk + TM.mdMint md @?= mintPk + TM.mdName md @?= "Solana Haskell NFT" + TM.mdSymbol md @?= "SHSDK" + TM.mdUri md @?= "https://example.com/nft.json" + TM.mdSellerFeeBasisPoints md @?= 550 + TM.mdCreators md @?= Just [TM.Creator payerPk True 60, TM.Creator secondCreatorPk False 40] + TM.mdPrimarySaleHappened md @?= False + TM.mdIsMutable md @?= True + TM.mdEditionNonce md @?= Nothing + TM.mdTokenStandard md @?= Nothing + TM.mdCollection md @?= Nothing + TM.mdUses md @?= Nothing, + testCase "decodeMetadata: rejects empty bytes" $ + case TM.decodeMetadata BS.empty of + Left _ -> pure () + Right _ -> assertFailure "expected decode failure for empty bytes", + testCase "decodeMetadata: rejects truncated mid-pubkey (40 bytes)" $ + case TM.decodeMetadata (BS.replicate 40 0) of + Left _ -> pure () + Right _ -> assertFailure "expected decode failure for 40 bytes", + testCase "decodeMetadata: rejects bad discriminator (key byte != 4)" $ do + fs <- getStateFixtures + let bs = requireFixture "metadata-account" fs + let corrupted = BS.cons 5 (BS.drop 1 bs) + case TM.decodeMetadata corrupted of + Left err -> assertBool "error message includes 'unexpected account key'" $ + "unexpected account key" `isInfixOf` err + Right _ -> assertFailure "expected decode failure for bad discriminator" + ], + testGroup + "PDA derivation" + [ testCase "deriveMetadataAddress matches fixture" $ do + fs <- getPdaFixtures + case TM.deriveMetadataAddress mintPk of + Nothing -> assertFailure "no metadata PDA found" + Just addr -> getSolanaPublicKeyRaw addr @?= requireFixture "metadata-address" fs, + testCase "deriveMasterEditionAddress matches fixture" $ do + fs <- getPdaFixtures + case TM.deriveMasterEditionAddress mintPk of + Nothing -> assertFailure "no master edition PDA found" + Just addr -> getSolanaPublicKeyRaw addr @?= requireFixture "master-edition-address" fs + ], + testGroup + "instruction data (golden)" + [ goldenCase getFixtures "CreateMetadataAccountV3-full" (TM.CreateMetadataAccountV3 dataV2Full True (Just (TM.CollectionDetailsV1 0))), + goldenCase getFixtures "CreateMetadataAccountV3-minimal" (TM.CreateMetadataAccountV3 dataV2Minimal True Nothing), + goldenCase getFixtures "UpdateMetadataAccountV2-some" (TM.UpdateMetadataAccountV2 (Just dataV2Full) (Just payerPk) (Just True) (Just True)), + goldenCase getFixtures "UpdateMetadataAccountV2-none" (TM.UpdateMetadataAccountV2 Nothing Nothing Nothing Nothing), + goldenCase getFixtures "CreateMasterEditionV3-some" (TM.CreateMasterEditionV3 (Just 100)), + goldenCase getFixtures "CreateMasterEditionV3-none" (TM.CreateMasterEditionV3 Nothing) + ], + testGroup + "properties" + [ testProperty "Binary round-trip" $ + forAll genTokenMetadataInstruction $ \i -> decode (encode i) === i, + testCase "decode fails on unknown discriminant" $ + case decodeOrFail (BL.pack [200]) :: Either (BL.ByteString, ByteOffset, String) (BL.ByteString, ByteOffset, TM.TokenMetadataInstruction) of + Left _ -> pure () + Right _ -> assertFailure "expected decode failure for discriminant 200" + ], + testGroup + "builder metas" + [ testCase "createMetadataAccountV3 matches create-v3-full-accounts fixture" $ do + expected <- getCreateV3Accounts + iAccounts (TM.createMetadataAccountV3 mintPk payerPk payerPk payerPk True dataV2Full True (Just (TM.CollectionDetailsV1 0))) + @?= expected, + testCase "updateMetadataAccountV2 metas" $ + case TM.deriveMetadataAddress mintPk of + Nothing -> assertFailure "no metadata PDA found" + Just metadataAddr -> + iAccounts (TM.updateMetadataAccountV2 mintPk payerPk Nothing Nothing Nothing Nothing) + @?= [ AccountMeta {accountPubKey = metadataAddr, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = payerPk, isSigner = True, isWritable = False} + ], + testCase "createMasterEditionV3 metas" $ + case (TM.deriveMasterEditionAddress mintPk, TM.deriveMetadataAddress mintPk) of + (Just editionAddr, Just metadataAddr) -> + iAccounts (TM.createMasterEditionV3 mintPk payerPk payerPk payerPk (Just 100)) + @?= [ AccountMeta {accountPubKey = editionAddr, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = mintPk, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = payerPk, isSigner = True, isWritable = False}, + AccountMeta {accountPubKey = payerPk, isSigner = True, isWritable = False}, + AccountMeta {accountPubKey = payerPk, isSigner = True, isWritable = True}, + AccountMeta {accountPubKey = metadataAddr, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = Token.tokenProgramId, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = SystemProgram.systemProgramId, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = Sysvar.rent, isSigner = False, isWritable = False} + ] + _ -> assertFailure "PDA derivation failed" + ] + ] + where + goldenCase getFixtures name i = + testCase name $ do + fs <- getFixtures + enc i @?= requireFixture name fs diff --git a/test/Test/NativePrograms/AddressLookupTable.hs b/test/Test/NativePrograms/AddressLookupTable.hs new file mode 100644 --- /dev/null +++ b/test/Test/NativePrograms/AddressLookupTable.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.NativePrograms.AddressLookupTable (tests) where + +import Data.Binary (decode, decodeOrFail, encode) +import Data.Binary.Get (ByteOffset) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BL +import Data.Word (Word8) +import Network.Solana.Core.Crypto (SolanaPublicKey, createSolanaKeypairFromSeed, getSolanaPublicKeyRaw, unsafeSolanaPublicKeyRaw) +import Network.Solana.Core.Instruction (AccountMeta (..), iAccounts) +import Network.Solana.Core.VersionedMessage qualified as VM +import Network.Solana.NativePrograms.AddressLookupTable qualified as ALT +import Network.Solana.NativePrograms.SystemProgram qualified as SP +import Test.Fixtures +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +payerPk :: SolanaPublicKey +payerPk = + case createSolanaKeypairFromSeed (BS.replicate 32 1) of + Just (pk, _) -> pk + Nothing -> error "failed to derive payer" + +tablePk, addrA, addrB, recipientPk, funderPk :: SolanaPublicKey +tablePk = unsafeSolanaPublicKeyRaw (replicate 32 31) +addrA = unsafeSolanaPublicKeyRaw (replicate 32 29) +addrB = unsafeSolanaPublicKeyRaw (replicate 32 30) +recipientPk = unsafeSolanaPublicKeyRaw (replicate 32 22) + +-- | Distinct from 'payerPk' (used as the authority) so that a builder +-- accidentally swapping its authority/payer arguments would be caught by +-- the meta tests below. +funderPk = unsafeSolanaPublicKeyRaw (replicate 32 32) + +-- | The bump seed for (payerPk, 12345), used to build the CreateLookupTable +-- golden without hard-coding it (it must equal the derivation, which is +-- separately checked against the Rust fixture). +lutBump :: Word8 +lutBump = + case ALT.deriveLookupTableAddress payerPk 12345 of + Just (_, bump) -> bump + Nothing -> error "no lookup table PDA found" + +enc :: ALT.AddressLookupTableInstruction -> BS.ByteString +enc = BL.toStrict . encode + +genAltInstruction :: Gen ALT.AddressLookupTableInstruction +genAltInstruction = + oneof + [ ALT.CreateLookupTable <$> arbitrary <*> arbitrary, + pure ALT.FreezeLookupTable, + ALT.ExtendLookupTable <$> listOf genPubkey, + pure ALT.DeactivateLookupTable, + pure ALT.CloseLookupTable + ] + where + genPubkey = unsafeSolanaPublicKeyRaw <$> vectorOf 32 arbitrary + +tests :: TestTree +tests = + withResource (loadFixtures "test/fixtures/alt_instruction_data.json") (const (pure ())) $ \getFixtures -> + withResource (loadFixtures "test/fixtures/pda.json") (const (pure ())) $ \getPdaFixtures -> + withResource (loadFixtures "test/fixtures/state_fixtures.json") (const (pure ())) $ \getStateFixtures -> + testGroup + "AddressLookupTable instruction data (golden + properties)" + [ testCase "decodeLookupTable: lookup-table golden" $ do + fs <- getStateFixtures + let bs = requireFixture "lookup-table" fs + case ALT.decodeLookupTable bs of + Left err -> assertFailure $ "decode failed: " <> err + Right lts -> do + ALT.ltDeactivationSlot lts @?= maxBound + ALT.ltLastExtendedSlot lts @?= 12345 + ALT.ltLastExtendedSlotStartIndex lts @?= 1 + ALT.ltAuthority lts @?= Just payerPk + ALT.ltAddresses lts + @?= [ unsafeSolanaPublicKeyRaw (replicate 32 2), + addrA, + addrB + ], + testCase "lookupTableToAccount builds the VersionedMessage account" $ do + fs <- getStateFixtures + let bs = requireFixture "lookup-table" fs + case ALT.decodeLookupTable bs of + Left err -> assertFailure $ "decode failed: " <> err + Right lts -> + ALT.lookupTableToAccount tablePk lts + @?= VM.AddressLookupTableAccount + tablePk + [unsafeSolanaPublicKeyRaw (replicate 32 2), addrA, addrB], + testCase "decodeLookupTable: rejects 55 bytes (below the fixed meta region)" $ do + let bs = BS.replicate 55 0 + case ALT.decodeLookupTable bs of + Left _ -> pure () + Right _ -> assertFailure "expected decode failure for 55 bytes", + testCase "decodeLookupTable: rejects an addresses remainder not divisible by 32" $ do + fs <- getStateFixtures + let bs = requireFixture "lookup-table" fs <> BS.singleton 0 + case ALT.decodeLookupTable bs of + Left _ -> pure () + Right _ -> assertFailure "expected decode failure for a non-multiple-of-32 remainder", + testCase "decodeLookupTable: rejects uninitialized (discriminant 0)" $ do + let bs = BS.replicate 56 0 + case ALT.decodeLookupTable bs of + Left err -> assertBool "error message mentions uninitialized" ("uninitialized" `elem` words err) + Right _ -> assertFailure "expected decode failure for discriminant 0", + testCase "decodeLookupTable: decodes None authority" $ do + let addr7 = unsafeSolanaPublicKeyRaw (replicate 32 7) + meta = + BS.pack + ( [1, 0, 0, 0] -- discriminant = 1 (initialized) + <> replicate 8 0xff -- deactivationSlot = maxBound (u64 LE) + <> replicate 8 0 -- lastExtendedSlot = 0 (u64 LE) + <> [0] -- lastExtendedSlotStartIndex = 0 + <> [0] -- authority option tag = None + <> replicate 34 0 -- padding to the 56-byte meta boundary + ) + bs = meta <> getSolanaPublicKeyRaw addr7 + case ALT.decodeLookupTable bs of + Left err -> assertFailure $ "decode failed: " <> err + Right lts -> do + ALT.ltAuthority lts @?= Nothing + ALT.ltAddresses lts @?= [addr7], + testCase "decodeLookupTable: rejects invalid authority tag" $ do + let meta = + BS.pack + ( [1, 0, 0, 0] + <> replicate 8 0xff + <> replicate 8 0 + <> [0] + <> [2] -- invalid authority option tag + <> replicate 34 0 + ) + bs = meta <> getSolanaPublicKeyRaw (unsafeSolanaPublicKeyRaw (replicate 32 7)) + case ALT.decodeLookupTable bs of + Left _ -> pure () + Right _ -> assertFailure "expected decode failure for invalid authority tag", + testCase "deriveLookupTableAddress matches Rust (address and bump)" $ do + fs <- getPdaFixtures + case ALT.deriveLookupTableAddress payerPk 12345 of + Nothing -> assertFailure "no lookup table PDA found" + Just (addr, bump) -> do + getSolanaPublicKeyRaw addr @?= requireFixture "lookup-table-address" fs + BS.singleton bump @?= requireFixture "lookup-table-bump" fs, + goldenCase getFixtures "CreateLookupTable" (ALT.CreateLookupTable 12345 lutBump), + goldenCase getFixtures "FreezeLookupTable" ALT.FreezeLookupTable, + goldenCase getFixtures "ExtendLookupTable" (ALT.ExtendLookupTable [addrA, addrB]), + goldenCase getFixtures "DeactivateLookupTable" ALT.DeactivateLookupTable, + goldenCase getFixtures "CloseLookupTable" ALT.CloseLookupTable, + testProperty "Binary round-trip" $ + forAll genAltInstruction $ \ai -> decode (encode ai) === ai, + testCase "decode fails on unknown discriminant" $ + case decodeOrFail (BL.pack [5, 0, 0, 0]) :: Either (BL.ByteString, ByteOffset, String) (BL.ByteString, ByteOffset, ALT.AddressLookupTableInstruction) of + Left _ -> pure () + Right _ -> assertFailure "expected decode failure for discriminant 5", + testCase "createLookupTable metas (and returned table address)" $ do + fs <- getPdaFixtures + let (ix, table) = ALT.createLookupTable payerPk funderPk 12345 + getSolanaPublicKeyRaw table @?= requireFixture "lookup-table-address" fs + iAccounts ix + @?= [ AccountMeta table False True, + AccountMeta payerPk False False, + AccountMeta funderPk True True, + AccountMeta SP.systemProgramId False False + ], + testCase "freezeLookupTable metas" $ + iAccounts (ALT.freezeLookupTable tablePk payerPk) + @?= [ AccountMeta tablePk False True, + AccountMeta payerPk True False + ], + testCase "extendLookupTable metas (no payer)" $ + iAccounts (ALT.extendLookupTable tablePk payerPk Nothing [addrA, addrB]) + @?= [ AccountMeta tablePk False True, + AccountMeta payerPk True False + ], + testCase "extendLookupTable metas (with payer)" $ + iAccounts (ALT.extendLookupTable tablePk payerPk (Just funderPk) [addrA, addrB]) + @?= [ AccountMeta tablePk False True, + AccountMeta payerPk True False, + AccountMeta funderPk True True, + AccountMeta SP.systemProgramId False False + ], + testCase "deactivateLookupTable metas" $ + iAccounts (ALT.deactivateLookupTable tablePk payerPk) + @?= [ AccountMeta tablePk False True, + AccountMeta payerPk True False + ], + testCase "closeLookupTable metas" $ + iAccounts (ALT.closeLookupTable tablePk payerPk recipientPk) + @?= [ AccountMeta tablePk False True, + AccountMeta payerPk True False, + AccountMeta recipientPk False True + ] + ] + where + goldenCase getFixtures name li = + testCase name $ do + fs <- getFixtures + enc li @?= requireFixture name fs diff --git a/test/Test/NativePrograms/BpfLoaderUpgradeable.hs b/test/Test/NativePrograms/BpfLoaderUpgradeable.hs new file mode 100644 --- /dev/null +++ b/test/Test/NativePrograms/BpfLoaderUpgradeable.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.NativePrograms.BpfLoaderUpgradeable (tests) where + +import Data.Binary (decode, decodeOrFail, encode) +import Data.Binary.Get (ByteOffset) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BL +import Network.Solana.Core.Crypto (SolanaPublicKey, createSolanaKeypairFromSeed, getSolanaPublicKeyRaw, unsafeSolanaPublicKeyRaw) +import Network.Solana.Core.Instruction (AccountMeta (..), iAccounts) +import Network.Solana.NativePrograms.BpfLoaderUpgradeable qualified as Loader +import Network.Solana.NativePrograms.SystemProgram qualified as SP +import Network.Solana.Sysvar qualified as Sysvar +import Test.Fixtures +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +bufferPk, programPk, spillPk, newAuthPk :: SolanaPublicKey +bufferPk = unsafeSolanaPublicKeyRaw (replicate 32 24) +programPk = unsafeSolanaPublicKeyRaw (replicate 32 23) +spillPk = unsafeSolanaPublicKeyRaw (replicate 32 22) +newAuthPk = unsafeSolanaPublicKeyRaw (replicate 32 20) + +programDataPk, recipientPk, authorityPk' :: SolanaPublicKey +programDataPk = unsafeSolanaPublicKeyRaw (replicate 32 25) +recipientPk = unsafeSolanaPublicKeyRaw (replicate 32 26) +authorityPk' = unsafeSolanaPublicKeyRaw (replicate 32 27) + +payerPk :: SolanaPublicKey +payerPk = + case createSolanaKeypairFromSeed (BS.replicate 32 1) of + Just (pk, _) -> pk + Nothing -> error "failed to derive payer" + +enc :: Loader.UpgradeableLoaderInstruction -> BS.ByteString +enc = BL.toStrict . encode + +genLoaderInstruction :: Gen Loader.UpgradeableLoaderInstruction +genLoaderInstruction = + oneof + [ pure Loader.InitializeBuffer, + Loader.Write <$> arbitrary <*> (BS.pack <$> listOf arbitrary), + Loader.DeployWithMaxDataLen <$> arbitrary, + pure Loader.Upgrade, + pure Loader.SetAuthority, + pure Loader.Close, + Loader.ExtendProgram <$> arbitrary, + pure Loader.SetAuthorityChecked + ] + +tests :: TestTree +tests = + withResource (loadFixtures "test/fixtures/loader_instruction_data.json") (const (pure ())) $ \getFixtures -> + withResource (loadFixtures "test/fixtures/pda.json") (const (pure ())) $ \getPdaFixtures -> + testGroup + "BpfLoaderUpgradeable instruction data (golden + properties)" + [ goldenCase getFixtures "InitializeBuffer" Loader.InitializeBuffer, + goldenCase getFixtures "Write" (Loader.Write 128 (BS.replicate 64 0xAB)), + goldenCase getFixtures "DeployWithMaxDataLen" (Loader.DeployWithMaxDataLen 1048576), + goldenCase getFixtures "Upgrade" Loader.Upgrade, + goldenCase getFixtures "SetAuthority" Loader.SetAuthority, + goldenCase getFixtures "Close" Loader.Close, + goldenCase getFixtures "ExtendProgram" (Loader.ExtendProgram 4096), + goldenCase getFixtures "SetAuthorityChecked" Loader.SetAuthorityChecked, + testProperty "Binary round-trip" $ + forAll genLoaderInstruction $ \li -> decode (encode li) === li, + testCase "decode fails on unknown discriminant" $ + case decodeOrFail (BL.pack [8, 0, 0, 0]) :: Either (BL.ByteString, ByteOffset, String) (BL.ByteString, ByteOffset, Loader.UpgradeableLoaderInstruction) of + Left _ -> pure () + Right _ -> assertFailure "expected decode failure for discriminant 8", + testCase "programDataAddress matches Rust" $ do + fs <- getPdaFixtures + case Loader.programDataAddress programPk of + Nothing -> assertFailure "no programdata PDA found" + Just addr -> getSolanaPublicKeyRaw addr @?= requireFixture "programdata-address" fs, + testCase "initializeBuffer metas" $ + iAccounts (Loader.initializeBuffer bufferPk payerPk) + @?= [ AccountMeta bufferPk False True, + AccountMeta payerPk False False + ], + testCase "write metas" $ + iAccounts (Loader.write bufferPk payerPk 128 (BS.replicate 64 0xAB)) + @?= [ AccountMeta bufferPk False True, + AccountMeta payerPk True False + ], + testCase "deployWithMaxDataLen metas" $ + iAccounts (Loader.deployWithMaxDataLen payerPk programDataPk programPk bufferPk authorityPk' 1048576) + @?= [ AccountMeta payerPk True True, + AccountMeta programDataPk False True, + AccountMeta programPk False True, + AccountMeta bufferPk False True, + AccountMeta Sysvar.rent False False, + AccountMeta Sysvar.clock False False, + AccountMeta SP.systemProgramId False False, + AccountMeta authorityPk' True False + ], + testCase "upgrade metas" $ + iAccounts (Loader.upgrade programDataPk programPk bufferPk spillPk payerPk) + @?= [ AccountMeta programDataPk False True, + AccountMeta programPk False True, + AccountMeta bufferPk False True, + AccountMeta spillPk False True, + AccountMeta Sysvar.rent False False, + AccountMeta Sysvar.clock False False, + AccountMeta payerPk True False + ], + testCase "setAuthority metas" $ + iAccounts (Loader.setAuthority bufferPk payerPk newAuthPk) + @?= [ AccountMeta bufferPk False True, + AccountMeta payerPk True False, + AccountMeta newAuthPk False False + ], + testCase "setAuthorityChecked metas" $ + iAccounts (Loader.setAuthorityChecked bufferPk payerPk newAuthPk) + @?= [ AccountMeta bufferPk False True, + AccountMeta payerPk True False, + AccountMeta newAuthPk True False + ], + testCase "closeAccount metas (no associated program)" $ + iAccounts (Loader.closeAccount bufferPk recipientPk payerPk Nothing) + @?= [ AccountMeta bufferPk False True, + AccountMeta recipientPk False True, + AccountMeta payerPk True False + ], + testCase "closeAccount metas (programdata close)" $ + iAccounts (Loader.closeAccount programDataPk recipientPk payerPk (Just programPk)) + @?= [ AccountMeta programDataPk False True, + AccountMeta recipientPk False True, + AccountMeta payerPk True False, + AccountMeta programPk False True + ], + testCase "extendProgram metas (no payer)" $ + iAccounts (Loader.extendProgram programDataPk programPk Nothing 4096) + @?= [ AccountMeta programDataPk False True, + AccountMeta programPk False True + ], + testCase "extendProgram metas (with payer)" $ + iAccounts (Loader.extendProgram programDataPk programPk (Just payerPk) 4096) + @?= [ AccountMeta programDataPk False True, + AccountMeta programPk False True, + AccountMeta SP.systemProgramId False False, + AccountMeta payerPk True True + ] + ] + where + goldenCase getFixtures name li = + testCase name $ do + fs <- getFixtures + enc li @?= requireFixture name fs diff --git a/test/Test/NativePrograms/ComputeBudget.hs b/test/Test/NativePrograms/ComputeBudget.hs new file mode 100644 --- /dev/null +++ b/test/Test/NativePrograms/ComputeBudget.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.NativePrograms.ComputeBudget (tests) where + +import Data.Binary (decode, decodeOrFail, encode) +import Data.Binary.Get (ByteOffset) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BL +import Network.Solana.Core.Instruction +import Network.Solana.NativePrograms.ComputeBudget qualified as CB +import Test.Fixtures +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +dataOf :: Instruction -> BS.ByteString +dataOf = instrData . iData + +genComputeBudgetInstruction :: Gen CB.ComputeBudgetInstruction +genComputeBudgetInstruction = + oneof + [ CB.RequestHeapFrame <$> arbitrary, + CB.SetComputeUnitLimit <$> arbitrary, + CB.SetComputeUnitPrice <$> arbitrary, + CB.SetLoadedAccountsDataSizeLimit <$> arbitrary + ] + +tests :: TestTree +tests = + withResource + (loadFixtures "test/fixtures/compute_budget_instruction_data.json") + (const (pure ())) + $ \getFixtures -> + testGroup + "ComputeBudget (golden + properties)" + [ testCase "RequestHeapFrame" $ do + fs <- getFixtures + dataOf (CB.requestHeapFrame 32768) @?= requireFixture "RequestHeapFrame" fs, + testCase "SetComputeUnitLimit" $ do + fs <- getFixtures + dataOf (CB.setComputeUnitLimit 200000) @?= requireFixture "SetComputeUnitLimit" fs, + testCase "SetComputeUnitPrice" $ do + fs <- getFixtures + dataOf (CB.setComputeUnitPrice 1000) @?= requireFixture "SetComputeUnitPrice" fs, + testCase "SetLoadedAccountsDataSizeLimit" $ do + fs <- getFixtures + dataOf (CB.setLoadedAccountsDataSizeLimit 65536) + @?= requireFixture "SetLoadedAccountsDataSizeLimit" fs, + testCase "builders take no accounts" $ do + iAccounts (CB.requestHeapFrame 1024) @?= [] + iAccounts (CB.setComputeUnitLimit 1) @?= [] + iAccounts (CB.setComputeUnitPrice 1) @?= [] + iAccounts (CB.setLoadedAccountsDataSizeLimit 1) @?= [], + testProperty "Binary round-trip" $ + forAll genComputeBudgetInstruction $ \cbi -> decode (encode cbi) === cbi, + testCase "decode fails on unknown discriminant" $ + case decodeOrFail (BL.pack [5]) :: Either (BL.ByteString, ByteOffset, String) (BL.ByteString, ByteOffset, CB.ComputeBudgetInstruction) of + Left _ -> pure () + Right _ -> assertFailure "expected decode failure for discriminant 5" + ] diff --git a/test/Test/NativePrograms/Secp256k1.hs b/test/Test/NativePrograms/Secp256k1.hs new file mode 100644 --- /dev/null +++ b/test/Test/NativePrograms/Secp256k1.hs @@ -0,0 +1,75 @@ +module Test.NativePrograms.Secp256k1 (tests) where + +import Control.Exception (ErrorCall, evaluate, try) +import Data.Binary (decode, encode) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BL +import Network.Solana.Core.Instruction (iAccounts, iData, instrData) +import Network.Solana.NativePrograms.Secp256k1 qualified as Secp +import Test.Fixtures +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +genOffsets :: Gen Secp.SecpSignatureOffsets +genOffsets = + Secp.SecpSignatureOffsets + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +tests :: TestTree +tests = + withResource (loadFixtures "test/fixtures/secp256k1.json") (const (pure ())) $ \getFixtures -> + testGroup + "Secp256k1 instruction data (golden + properties)" + [ testCase "newSecp256k1Instruction reconstructs the full instruction data" $ do + fs <- getFixtures + let ethAddress = requireFixture "secp-eth-address" fs + signature = requireFixture "secp-signature" fs + recoveryId = BS.head (requireFixture "secp-recovery-id" fs) + message = requireFixture "secp-message" fs + ix = Secp.newSecp256k1Instruction ethAddress signature recoveryId message + instrData (iData ix) @?= requireFixture "secp-full-instruction-data" fs, + testCase "offsets golden: decode from the full instruction data" $ do + fs <- getFixtures + let full = requireFixture "secp-full-instruction-data" fs + offsets = decode (BL.fromStrict (BS.take 11 (BS.drop 1 full))) :: Secp.SecpSignatureOffsets + offsets + @?= Secp.SecpSignatureOffsets + { Secp.ssoSignatureOffset = 32, + Secp.ssoSignatureInstructionIndex = 0, + Secp.ssoEthAddressOffset = 12, + Secp.ssoEthAddressInstructionIndex = 0, + Secp.ssoMessageDataOffset = 97, + Secp.ssoMessageDataSize = 10, + Secp.ssoMessageInstructionIndex = 0 + }, + testProperty "SecpSignatureOffsets Binary round-trip" $ + forAll genOffsets $ \o -> decode (encode o) === o, + testCase "newSecp256k1Instruction rejects a 19-byte ethAddress" $ do + result <- + try + ( evaluate + (Secp.newSecp256k1Instruction (BS.replicate 19 0) (BS.replicate 64 0) 0 (BS.replicate 10 0)) + ) + case result of + Left (_ :: ErrorCall) -> pure () + Right _ -> assertFailure "expected error for a 19-byte ethAddress", + testCase "newSecp256k1Instruction rejects a 63-byte signature" $ do + result <- + try + ( evaluate + (Secp.newSecp256k1Instruction (BS.replicate 20 0) (BS.replicate 63 0) 0 (BS.replicate 10 0)) + ) + case result of + Left (_ :: ErrorCall) -> pure () + Right _ -> assertFailure "expected error for a 63-byte signature", + testCase "newSecp256k1Instruction takes no accounts" $ + iAccounts (Secp.newSecp256k1Instruction (BS.replicate 20 0) (BS.replicate 64 0) 0 (BS.replicate 10 0)) + @?= [] + ] diff --git a/test/Test/NativePrograms/Stake.hs b/test/Test/NativePrograms/Stake.hs new file mode 100644 --- /dev/null +++ b/test/Test/NativePrograms/Stake.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.NativePrograms.Stake (tests) where + +import Data.Binary (decode, decodeOrFail, encode) +import Data.Binary.Get (ByteOffset) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BL +import Network.Solana.Core.Crypto (SolanaPublicKey, createSolanaKeypairFromSeed, unsafeSolanaPublicKeyRaw) +import Network.Solana.Core.Instruction (AccountMeta (..), iAccounts) +import Network.Solana.NativePrograms.Stake qualified as Stake +import Network.Solana.Sysvar qualified as Sysvar +import Test.Fixtures +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +custodianPk, newAuthPk, withdrawerPk :: SolanaPublicKey +custodianPk = unsafeSolanaPublicKeyRaw (replicate 32 18) +newAuthPk = unsafeSolanaPublicKeyRaw (replicate 32 20) +withdrawerPk = unsafeSolanaPublicKeyRaw (replicate 32 28) + +stakeAcctPk, votePk, recipientPk' :: SolanaPublicKey +stakeAcctPk = unsafeSolanaPublicKeyRaw (replicate 32 21) +votePk = unsafeSolanaPublicKeyRaw (replicate 32 17) +recipientPk' = unsafeSolanaPublicKeyRaw (replicate 32 22) + +payerPk :: SolanaPublicKey +payerPk = + case createSolanaKeypairFromSeed (BS.replicate 32 1) of + Just (pk, _) -> pk + Nothing -> error "failed to derive payer" + +fixedAuthorized :: Stake.Authorized +fixedAuthorized = Stake.Authorized {Stake.aStaker = payerPk, Stake.aWithdrawer = payerPk} + +fixedLockup :: Stake.Lockup +fixedLockup = Stake.Lockup {Stake.lUnixTimestamp = 1700000000, Stake.lEpoch = 300, Stake.lCustodian = custodianPk} + +enc :: Stake.StakeInstruction -> BS.ByteString +enc = BL.toStrict . encode + +genStakeInstruction :: Gen Stake.StakeInstruction +genStakeInstruction = + oneof + [ Stake.Initialize <$> genAuthorized <*> genLockup, + Stake.Authorize <$> genPk <*> genAuth, + pure Stake.DelegateStake, + Stake.Split <$> arbitrary, + Stake.Withdraw <$> arbitrary, + pure Stake.Deactivate, + Stake.SetLockup <$> genLockupArgs, + pure Stake.Merge, + pure Stake.InitializeChecked, + Stake.AuthorizeChecked <$> genAuth, + pure Stake.GetMinimumDelegation + ] + where + genPk = unsafeSolanaPublicKeyRaw <$> vectorOf 32 arbitrary + genAuth = elements [Stake.AuthorizeStaker, Stake.AuthorizeWithdrawer] + genAuthorized = Stake.Authorized <$> genPk <*> genPk + genLockup = Stake.Lockup <$> arbitrary <*> arbitrary <*> genPk + genLockupArgs = + Stake.LockupArgs + <$> oneof [pure Nothing, Just <$> arbitrary] + <*> oneof [pure Nothing, Just <$> arbitrary] + <*> oneof [pure Nothing, Just <$> genPk] + +tests :: TestTree +tests = testGroup "Stake" [instructionDataTests, stakeStateTests] + +stakeStateTests :: TestTree +stakeStateTests = + withResource (loadFixtures "test/fixtures/state_fixtures.json") (const (pure ())) $ \getStateFixtures -> + testGroup + "Stake account state (golden + rejection)" + [ testCase "decodeStakeAccount: stake-account golden (StakeActive)" $ do + fs <- getStateFixtures + let bs = requireFixture "stake-account" fs + case Stake.decodeStakeAccount bs of + Left err -> assertFailure $ "decode failed: " <> err + Right (Stake.StakeActive meta delegation credits flags) -> do + Stake.smRentExemptReserve meta @?= 2282880 + Stake.smAuthorized meta @?= fixedAuthorized + Stake.smLockup meta @?= fixedLockup + Stake.sdVoter delegation @?= votePk + Stake.sdStake delegation @?= 1000000 + Stake.sdActivationEpoch delegation @?= 250 + Stake.sdDeactivationEpoch delegation @?= maxBound + Stake.sdWarmupCooldownRate delegation @?= 0.25 + credits @?= 42 + flags @?= 0 + Right other -> assertFailure ("expected StakeActive, got " <> show other), + testCase "decodeStakeAccount: stake-account-initialized golden (StakeInitialized)" $ do + fs <- getStateFixtures + let bs = requireFixture "stake-account-initialized" fs + case Stake.decodeStakeAccount bs of + Left err -> assertFailure $ "decode failed: " <> err + Right (Stake.StakeInitialized meta) -> do + Stake.smRentExemptReserve meta @?= 2282880 + Stake.smAuthorized meta @?= fixedAuthorized + Stake.smLockup meta @?= fixedLockup + Right other -> assertFailure ("expected StakeInitialized, got " <> show other), + testCase "decodeStakeAccount: rejects discriminant 4" $ do + let bs = BS.pack ([4, 0, 0, 0] <> replicate 196 0) + case Stake.decodeStakeAccount bs of + Left _ -> pure () + Right _ -> assertFailure "expected decode failure for discriminant 4", + testCase "decodeStakeAccount: decode tolerates trailing padding" $ do + fs <- getStateFixtures + let bs = requireFixture "stake-account" fs + padded = bs <> BS.replicate 3 0 + Stake.decodeStakeAccount padded @?= Stake.decodeStakeAccount bs + ] + +instructionDataTests :: TestTree +instructionDataTests = + withResource (loadFixtures "test/fixtures/stake_instruction_data.json") (const (pure ())) $ \getFixtures -> + testGroup + "Stake instruction data (golden + properties)" + [ goldenCase getFixtures "Initialize" (Stake.Initialize fixedAuthorized fixedLockup), + goldenCase getFixtures "Authorize-staker" (Stake.Authorize newAuthPk Stake.AuthorizeStaker), + goldenCase getFixtures "Authorize-withdrawer" (Stake.Authorize newAuthPk Stake.AuthorizeWithdrawer), + goldenCase getFixtures "DelegateStake" Stake.DelegateStake, + goldenCase getFixtures "Split" (Stake.Split 250000), + goldenCase getFixtures "Withdraw" (Stake.Withdraw 500000), + goldenCase getFixtures "Deactivate" Stake.Deactivate, + goldenCase getFixtures "SetLockup-some" (Stake.SetLockup (Stake.LockupArgs (Just 1700000000) (Just 300) (Just custodianPk))), + goldenCase getFixtures "SetLockup-none" (Stake.SetLockup (Stake.LockupArgs Nothing Nothing Nothing)), + goldenCase getFixtures "Merge" Stake.Merge, + goldenCase getFixtures "InitializeChecked" Stake.InitializeChecked, + goldenCase getFixtures "AuthorizeChecked" (Stake.AuthorizeChecked Stake.AuthorizeWithdrawer), + goldenCase getFixtures "GetMinimumDelegation" Stake.GetMinimumDelegation, + testProperty "Binary round-trip" $ + forAll genStakeInstruction $ \si -> decode (encode si) === si, + testCase "decode fails on unknown discriminant" $ + case decodeOrFail (BL.pack [16, 0, 0, 0]) :: Either (BL.ByteString, ByteOffset, String) (BL.ByteString, ByteOffset, Stake.StakeInstruction) of + Left _ -> pure () + Right _ -> assertFailure "expected decode failure for discriminant 16", + testCase "initialize metas" $ + iAccounts (Stake.initialize stakeAcctPk fixedAuthorized fixedLockup) + @?= [ AccountMeta stakeAcctPk False True, + AccountMeta Sysvar.rent False False + ], + testCase "authorize metas (no custodian)" $ + iAccounts (Stake.authorize stakeAcctPk payerPk newAuthPk Stake.AuthorizeStaker Nothing) + @?= [ AccountMeta stakeAcctPk False True, + AccountMeta Sysvar.clock False False, + AccountMeta payerPk True False + ], + testCase "authorize metas (custodian)" $ + iAccounts (Stake.authorize stakeAcctPk payerPk newAuthPk Stake.AuthorizeWithdrawer (Just custodianPk)) + @?= [ AccountMeta stakeAcctPk False True, + AccountMeta Sysvar.clock False False, + AccountMeta payerPk True False, + AccountMeta custodianPk True False + ], + testCase "delegateStake metas" $ + iAccounts (Stake.delegateStake stakeAcctPk payerPk votePk) + @?= [ AccountMeta stakeAcctPk False True, + AccountMeta votePk False False, + AccountMeta Sysvar.clock False False, + AccountMeta Sysvar.stakeHistory False False, + AccountMeta Stake.stakeConfigId False False, + AccountMeta payerPk True False + ], + testCase "split metas" $ + iAccounts (Stake.split stakeAcctPk recipientPk' payerPk 250000) + @?= [ AccountMeta stakeAcctPk False True, + AccountMeta recipientPk' False True, + AccountMeta payerPk True False + ], + testCase "withdraw metas (no custodian)" $ + iAccounts (Stake.withdraw stakeAcctPk recipientPk' payerPk 500000 Nothing) + @?= [ AccountMeta stakeAcctPk False True, + AccountMeta recipientPk' False True, + AccountMeta Sysvar.clock False False, + AccountMeta Sysvar.stakeHistory False False, + AccountMeta payerPk True False + ], + testCase "withdraw metas (custodian)" $ + iAccounts (Stake.withdraw stakeAcctPk recipientPk' payerPk 500000 (Just custodianPk)) + @?= [ AccountMeta stakeAcctPk False True, + AccountMeta recipientPk' False True, + AccountMeta Sysvar.clock False False, + AccountMeta Sysvar.stakeHistory False False, + AccountMeta payerPk True False, + AccountMeta custodianPk True False + ], + testCase "deactivate metas" $ + iAccounts (Stake.deactivate stakeAcctPk payerPk) + @?= [ AccountMeta stakeAcctPk False True, + AccountMeta Sysvar.clock False False, + AccountMeta payerPk True False + ], + testCase "setLockup metas" $ + iAccounts (Stake.setLockup stakeAcctPk (Stake.LockupArgs Nothing Nothing Nothing) custodianPk) + @?= [ AccountMeta stakeAcctPk False True, + AccountMeta custodianPk True False + ], + testCase "merge metas" $ + iAccounts (Stake.merge stakeAcctPk recipientPk' payerPk) + @?= [ AccountMeta stakeAcctPk False True, + AccountMeta recipientPk' False True, + AccountMeta Sysvar.clock False False, + AccountMeta Sysvar.stakeHistory False False, + AccountMeta payerPk True False + ], + testCase "initializeChecked metas" $ + iAccounts (Stake.initializeChecked stakeAcctPk (Stake.Authorized {Stake.aStaker = payerPk, Stake.aWithdrawer = withdrawerPk})) + @?= [ AccountMeta stakeAcctPk False True, + AccountMeta Sysvar.rent False False, + AccountMeta payerPk False False, + AccountMeta withdrawerPk True False + ], + testCase "authorizeChecked metas" $ + iAccounts (Stake.authorizeChecked stakeAcctPk payerPk newAuthPk Stake.AuthorizeStaker Nothing) + @?= [ AccountMeta stakeAcctPk False True, + AccountMeta Sysvar.clock False False, + AccountMeta payerPk True False, + AccountMeta newAuthPk True False + ], + testCase "authorizeChecked metas (custodian)" $ + iAccounts (Stake.authorizeChecked stakeAcctPk payerPk newAuthPk Stake.AuthorizeWithdrawer (Just custodianPk)) + @?= [ AccountMeta stakeAcctPk False True, + AccountMeta Sysvar.clock False False, + AccountMeta payerPk True False, + AccountMeta newAuthPk True False, + AccountMeta custodianPk True False + ] + ] + where + goldenCase getFixtures name si = + testCase name $ do + fs <- getFixtures + enc si @?= requireFixture name fs diff --git a/test/Test/NativePrograms/SystemProgram.hs b/test/Test/NativePrograms/SystemProgram.hs new file mode 100644 --- /dev/null +++ b/test/Test/NativePrograms/SystemProgram.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.NativePrograms.SystemProgram (tests) where + +import Data.Binary (decode, decodeOrFail, encode) +import Data.Binary.Get (ByteOffset) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BL +import Network.Solana.Core.Block (BlockHash (..)) +import Network.Solana.Core.Crypto (SolanaPublicKey, createSolanaKeypairFromSeed, unsafeSolanaPublicKeyRaw) +import Network.Solana.Core.Instruction +import Network.Solana.NativePrograms.SystemProgram qualified as SP +import Network.Solana.Sysvar qualified as Sysvar +import Test.Fixtures +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +basePk, ownerPk, authorityPk, funderPk, newAccountPk :: SolanaPublicKey +basePk = unsafeSolanaPublicKeyRaw (replicate 32 3) +ownerPk = unsafeSolanaPublicKeyRaw (replicate 32 5) +authorityPk = unsafeSolanaPublicKeyRaw (replicate 32 6) +funderPk = unsafeSolanaPublicKeyRaw (replicate 32 7) +newAccountPk = unsafeSolanaPublicKeyRaw (replicate 32 8) + +seedStr :: String +seedStr = "hello-seed" + +dataOf :: Instruction -> BS.ByteString +dataOf = instrData . iData + +genSystemInstruction :: Gen SP.SystemInstruction +genSystemInstruction = + oneof + [ SP.CreateAccount <$> arbitrary <*> arbitrary <*> genPk, + SP.Assign <$> genPk, + SP.Transfer <$> arbitrary, + SP.CreateAccountWithSeed <$> genPk <*> genSeed <*> arbitrary <*> arbitrary <*> genPk, + pure SP.AdvanceNonceAccount, + SP.WithdrawNonceAccount <$> arbitrary, + SP.InitializeNonceAccount <$> genPk, + SP.AuthorizeNonceAccount <$> genPk, + SP.Allocate <$> arbitrary, + SP.AllocateWithSeed <$> genPk <*> genSeed <*> arbitrary <*> genPk, + SP.AssignWithSeed <$> genPk <*> genSeed <*> genPk, + SP.TransferWithSeed <$> arbitrary <*> genSeed <*> genPk, + pure SP.UpgradeNonceAccount + ] + where + genPk = unsafeSolanaPublicKeyRaw <$> vectorOf 32 arbitrary + genSeed = listOf (elements (['a' .. 'z'] ++ ['0' .. '9'] ++ "-_")) + +payerPk :: SolanaPublicKey +payerPk = + case createSolanaKeypairFromSeed (BS.replicate 32 1) of + Just (pk, _) -> pk + Nothing -> error "failed to derive payer" + +tests :: TestTree +tests = testGroup "SystemProgram" [instructionDataTests, nonceStateTests] + +nonceStateTests :: TestTree +nonceStateTests = + withResource (loadFixtures "test/fixtures/state_fixtures.json") (const (pure ())) $ \getStateFixtures -> + testGroup + "SystemProgram nonce account state (golden + rejection)" + [ testCase "decodeNonceAccount: nonce-account golden" $ do + fs <- getStateFixtures + let bs = requireFixture "nonce-account" fs + durableNonceBytes = requireFixture "nonce-durable-hash" fs + case SP.decodeNonceAccount bs of + Left err -> assertFailure $ "decode failed: " <> err + Right ns -> case ns of + SP.NonceUninitialized -> assertFailure "expected NonceInitialized, got NonceUninitialized" + SP.NonceInitialized {SP.nsAuthority = auth, SP.nsDurableNonce = BlockHash nonceBytes, SP.nsLamportsPerSignature = fee} -> do + auth @?= payerPk + nonceBytes @?= durableNonceBytes + fee @?= 5000, + testCase "decodeNonceAccount: rejects unsupported version" $ do + let bs = BS.pack ([2, 0, 0, 0] <> replicate 76 0) + case SP.decodeNonceAccount bs of + Left _ -> pure () + Right _ -> assertFailure "expected decode failure for unsupported version", + testCase "decodeNonceAccount: rejects unknown state" $ do + let bs = BS.pack ([1, 0, 0, 0, 2, 0, 0, 0] <> replicate 72 0) + case SP.decodeNonceAccount bs of + Left _ -> pure () + Right _ -> assertFailure "expected decode failure for unknown state" + ] + +instructionDataTests :: TestTree +instructionDataTests = + withResource + (loadFixtures "test/fixtures/system_instruction_data.json") + (const (pure ())) + $ \getFixtures -> + testGroup + "SystemProgram instruction data (golden)" + [ testCase "CreateAccount" $ do + fs <- getFixtures + dataOf (SP.createAccount funderPk newAccountPk 1000000 165 ownerPk) + @?= requireFixture "CreateAccount" fs, + testCase "Assign" $ do + fs <- getFixtures + dataOf (SP.assignAccount newAccountPk ownerPk) + @?= requireFixture "Assign" fs, + testCase "Transfer" $ do + fs <- getFixtures + dataOf (SP.transfer funderPk newAccountPk 1000000) + @?= requireFixture "Transfer" fs, + testCase "CreateAccountWithSeed" $ do + fs <- getFixtures + dataOf (SP.createAccountWithSeed basePk seedStr funderPk newAccountPk 1000000 165 ownerPk) + @?= requireFixture "CreateAccountWithSeed" fs, + testCase "AdvanceNonceAccount" $ do + fs <- getFixtures + dataOf (SP.advanceNonceAccount newAccountPk authorityPk) + @?= requireFixture "AdvanceNonceAccount" fs, + testCase "WithdrawNonceAccount" $ do + fs <- getFixtures + dataOf (SP.withdrawNonceAccount newAccountPk authorityPk funderPk 1000000) + @?= requireFixture "WithdrawNonceAccount" fs, + testCase "InitializeNonceAccount" $ do + fs <- getFixtures + dataOf (SP.initializeNonceAccount newAccountPk authorityPk) + @?= requireFixture "InitializeNonceAccount" fs, + testCase "AuthorizeNonceAccount" $ do + fs <- getFixtures + dataOf (SP.authorizeNonceAccount newAccountPk basePk authorityPk) + @?= requireFixture "AuthorizeNonceAccount" fs, + testCase "UpgradeNonceAccount" $ do + fs <- getFixtures + dataOf (SP.upgradeNonceAccount newAccountPk) + @?= requireFixture "UpgradeNonceAccount" fs, + testCase "Allocate" $ do + fs <- getFixtures + dataOf (SP.allocate newAccountPk 165) + @?= requireFixture "Allocate" fs, + testCase "AllocateWithSeed" $ do + fs <- getFixtures + dataOf (SP.allocateWithSeed newAccountPk basePk seedStr 165 ownerPk) + @?= requireFixture "AllocateWithSeed" fs, + testCase "AssignWithSeed" $ do + fs <- getFixtures + dataOf (SP.assignWithSeed newAccountPk basePk seedStr ownerPk) + @?= requireFixture "AssignWithSeed" fs, + testCase "TransferWithSeed" $ do + fs <- getFixtures + dataOf (SP.transferWithSeed funderPk basePk seedStr ownerPk newAccountPk 1000000) + @?= requireFixture "TransferWithSeed" fs, + testCase "advanceNonceAccount account metas" $ + iAccounts (SP.advanceNonceAccount newAccountPk authorityPk) + @?= [ AccountMeta {accountPubKey = newAccountPk, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = Sysvar.recentBlockhashes, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = authorityPk, isSigner = True, isWritable = False} + ], + testCase "withdrawNonceAccount account metas" $ + iAccounts (SP.withdrawNonceAccount newAccountPk authorityPk funderPk 1000000) + @?= [ AccountMeta {accountPubKey = newAccountPk, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = funderPk, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = Sysvar.recentBlockhashes, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = Sysvar.rent, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = authorityPk, isSigner = True, isWritable = False} + ], + testCase "allocateWithSeed account metas" $ + iAccounts (SP.allocateWithSeed newAccountPk basePk seedStr 165 ownerPk) + @?= [ AccountMeta {accountPubKey = newAccountPk, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = basePk, isSigner = True, isWritable = False} + ], + testCase "transferWithSeed account metas" $ + iAccounts (SP.transferWithSeed funderPk basePk seedStr ownerPk newAccountPk 1000000) + @?= [ AccountMeta {accountPubKey = funderPk, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = basePk, isSigner = True, isWritable = False}, + AccountMeta {accountPubKey = newAccountPk, isSigner = False, isWritable = True} + ], + testProperty "SystemInstruction Binary round-trip" $ + forAll genSystemInstruction $ \si -> decode (encode si) === si, + testCase "decode fails on unknown discriminant" $ + case decodeOrFail (BL.pack [13, 0, 0, 0]) :: Either (BL.ByteString, ByteOffset, String) (BL.ByteString, ByteOffset, SP.SystemInstruction) of + Left _ -> pure () + Right _ -> assertFailure "expected decode failure for discriminant 13", + testCase "getBincodeString rejects length beyond Int range" $ + -- discriminant 3 (CreateAccountWithSeed) -> base pk (32 bytes) -> u64 length 2^63 + let bytes = BL.pack ([3, 0, 0, 0] <> replicate 32 3 <> [0, 0, 0, 0, 0, 0, 0, 0x80]) + in case decodeOrFail bytes :: Either (BL.ByteString, ByteOffset, String) (BL.ByteString, ByteOffset, SP.SystemInstruction) of + Left _ -> pure () + Right _ -> assertFailure "expected decode failure for absurd length" + ] diff --git a/test/Test/NativePrograms/Vote.hs b/test/Test/NativePrograms/Vote.hs new file mode 100644 --- /dev/null +++ b/test/Test/NativePrograms/Vote.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.NativePrograms.Vote (tests) where + +import Data.Binary (decode, decodeOrFail, encode) +import Data.Binary.Get (ByteOffset) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BL +import Network.Solana.Core.Crypto (SolanaPublicKey, createSolanaKeypairFromSeed, getSolanaPublicKeyRaw, toBase58String, unsafeSolanaPublicKeyRaw) +import Network.Solana.Core.Instruction (AccountMeta (..), iAccounts) +import Network.Solana.NativePrograms.Vote qualified as Vote +import Network.Solana.Sysvar qualified as Sysvar +import Test.Fixtures +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +votePk, nodePk, newAuthPk, recipientPk' :: SolanaPublicKey +votePk = unsafeSolanaPublicKeyRaw (replicate 32 17) +nodePk = unsafeSolanaPublicKeyRaw (replicate 32 19) +newAuthPk = unsafeSolanaPublicKeyRaw (replicate 32 20) +recipientPk' = unsafeSolanaPublicKeyRaw (replicate 32 22) + +payerPk :: SolanaPublicKey +payerPk = + case createSolanaKeypairFromSeed (BS.replicate 32 1) of + Just (pk, _) -> pk + Nothing -> error "failed to derive payer" + +fixedVoteInit :: Vote.VoteInit +fixedVoteInit = + Vote.VoteInit + { Vote.viNodePubkey = nodePk, + Vote.viAuthorizedVoter = payerPk, + Vote.viAuthorizedWithdrawer = payerPk, + Vote.viCommission = 5 + } + +enc :: Vote.VoteInstruction -> BS.ByteString +enc = BL.toStrict . encode + +genVoteInstruction :: Gen Vote.VoteInstruction +genVoteInstruction = + oneof + [ Vote.InitializeAccount <$> genVoteInit, + Vote.Authorize <$> genPk <*> genAuth, + Vote.Withdraw <$> arbitrary, + pure Vote.UpdateValidatorIdentity, + Vote.UpdateCommission <$> arbitrary, + Vote.AuthorizeChecked <$> genAuth + ] + where + genPk = unsafeSolanaPublicKeyRaw <$> vectorOf 32 arbitrary + genAuth = elements [Vote.AuthorizeVoter, Vote.AuthorizeWithdrawer] + genVoteInit = Vote.VoteInit <$> genPk <*> genPk <*> genPk <*> arbitrary + +tests :: TestTree +tests = + withResource (loadFixtures "test/fixtures/vote_instruction_data.json") (const (pure ())) $ \getFixtures -> + testGroup + "Vote instruction data (golden + properties)" + [ goldenCase getFixtures "InitializeAccount" (Vote.InitializeAccount fixedVoteInit), + goldenCase getFixtures "Authorize-voter" (Vote.Authorize newAuthPk Vote.AuthorizeVoter), + goldenCase getFixtures "Authorize-withdrawer" (Vote.Authorize newAuthPk Vote.AuthorizeWithdrawer), + goldenCase getFixtures "Withdraw" (Vote.Withdraw 500000), + goldenCase getFixtures "UpdateValidatorIdentity" Vote.UpdateValidatorIdentity, + goldenCase getFixtures "UpdateCommission" (Vote.UpdateCommission 5), + goldenCase getFixtures "AuthorizeChecked" (Vote.AuthorizeChecked Vote.AuthorizeWithdrawer), + testProperty "Binary round-trip" $ + forAll genVoteInstruction $ \vi -> decode (encode vi) === vi, + testCase "decode fails on unknown discriminant" $ + case decodeOrFail (BL.pack [2, 0, 0, 0]) :: Either (BL.ByteString, ByteOffset, String) (BL.ByteString, ByteOffset, Vote.VoteInstruction) of + Left _ -> pure () + Right _ -> assertFailure "expected decode failure for discriminant 2", + testCase "initializeVoteAccount metas" $ + iAccounts (Vote.initializeVoteAccount votePk fixedVoteInit) + @?= [ AccountMeta votePk False True, + AccountMeta Sysvar.rent False False, + AccountMeta Sysvar.clock False False, + AccountMeta nodePk True False + ], + testCase "authorizeVote metas" $ + iAccounts (Vote.authorizeVote votePk payerPk newAuthPk Vote.AuthorizeVoter) + @?= [ AccountMeta votePk False True, + AccountMeta Sysvar.clock False False, + AccountMeta payerPk True False + ], + testCase "withdrawVote metas" $ + iAccounts (Vote.withdrawVote votePk recipientPk' payerPk 500000) + @?= [ AccountMeta votePk False True, + AccountMeta recipientPk' False True, + AccountMeta payerPk True False + ], + testCase "updateValidatorIdentity metas" $ + iAccounts (Vote.updateValidatorIdentity votePk nodePk payerPk) + @?= [ AccountMeta votePk False True, + AccountMeta nodePk True False, + AccountMeta payerPk True False + ], + testCase "updateCommission metas" $ + iAccounts (Vote.updateCommission votePk payerPk 5) + @?= [ AccountMeta votePk False True, + AccountMeta payerPk True False + ], + testCase "authorizeVoteChecked metas" $ + iAccounts (Vote.authorizeVoteChecked votePk payerPk newAuthPk Vote.AuthorizeWithdrawer) + @?= [ AccountMeta votePk False True, + AccountMeta Sysvar.clock False False, + AccountMeta payerPk True False, + AccountMeta newAuthPk True False + ], + testCase "voteProgramId decodes to canonical bytes" $ do + toBase58String (getSolanaPublicKeyRaw Vote.voteProgramId) @?= "Vote111111111111111111111111111111111111111" + BS.length (getSolanaPublicKeyRaw Vote.voteProgramId) @?= 32 + ] + where + goldenCase getFixtures name vi = + testCase name $ do + fs <- getFixtures + enc vi @?= requireFixture name fs diff --git a/test/Test/RPC/Chain.hs b/test/Test/RPC/Chain.hs new file mode 100644 --- /dev/null +++ b/test/Test/RPC/Chain.hs @@ -0,0 +1,20 @@ +module Test.RPC.Chain (tests) where + +import Network.Solana.RPC.HTTP.Chain (percentilePriorityFee) +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "percentilePriorityFee" + [ testCase "empty samples -> 0" $ percentilePriorityFee 0.5 [] @?= 0, + testCase "all-zero samples -> 0" $ percentilePriorityFee 0.5 [0, 0] @?= 0, + testCase "single sample" $ percentilePriorityFee 0.5 [5] @?= 5, + testCase "median of four" $ percentilePriorityFee 0.5 [1, 2, 3, 4] @?= 2, + testCase "p75 of four" $ percentilePriorityFee 0.75 [1, 2, 3, 4] @?= 3, + testCase "p100 picks max" $ percentilePriorityFee 1.0 [7, 3] @?= 7, + testCase "negative p clamps to 0" $ percentilePriorityFee (-1) [9] @?= 9, + testCase "p above 1 clamps to 1" $ percentilePriorityFee 2 [1, 9] @?= 9, + testCase "zeros filtered before ranking" $ percentilePriorityFee 0.5 [0, 5, 0, 1] @?= 1 + ] diff --git a/test/Test/RPC/Parsers.hs b/test/Test/RPC/Parsers.hs new file mode 100644 --- /dev/null +++ b/test/Test/RPC/Parsers.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Golden tests for the RPC response parsers. +-- +-- Every fixture here is a real response captured from a local validator by +-- @tools/rpc-record/record.py@ -- not a hand-written sample -- so these tests +-- pin the @FromJSON@ instances against JSON a node actually produces, +-- including the fields it omits. That is the one thing the Rust-generated +-- byte vectors cannot cover, since the RPC layer's input is JSON rather than +-- a struct's serialization. +-- +-- The assertions deliberately reach past "it parsed": each one checks a value +-- that could only be right if the field mapping is, which is what catches a +-- parser wired to the wrong key. +module Test.RPC.Parsers (tests) where + +import Data.Aeson (FromJSON, Value) +import Data.Aeson.Types (parseEither, parseJSON) +import Data.Maybe (isJust) +import Network.Solana.Core.Account (Account, AccountInfo, Lamport (..), executable, lamports) +import Network.Solana.Core.Block (BlockHash, BlockHeight) +import Network.Solana.Core.Crypto (SolanaPublicKey) +import Network.Solana.RPC.HTTP.Account hiding (lamports) +import Network.Solana.RPC.HTTP.Account qualified as RpcAccount +import Network.Solana.RPC.HTTP.Block +import Network.Solana.RPC.HTTP.Chain +import Network.Solana.RPC.HTTP.Ledger +import Network.Solana.RPC.HTTP.Token +import Network.Solana.RPC.HTTP.Tokenomics +import Network.Solana.RPC.HTTP.Transaction +import Network.Solana.RPC.HTTP.Types +import Test.Fixtures +import Test.Tasty +import Test.Tasty.HUnit + +fixturePath :: FilePath +fixturePath = "test/fixtures/rpc_responses.json" + +-- | Decodes a recorded response's @result@ into the type its RPC binding +-- returns, failing the test with the parse error if the instance rejects what +-- the node actually sent. +withResult :: forall a. (FromJSON a) => String -> (a -> Assertion) -> Assertion +withResult name check = do + fs <- loadRpcFixtures fixturePath + case parseEither (parseJSON @a) (requireRpcResult name fs) of + Left err -> assertFailure ("failed to parse recorded " <> name <> " response: " <> err) + Right parsed -> check parsed + +-- | For results the bindings hand back untouched (plain numbers, strings). +withRawResult :: String -> (Value -> Assertion) -> Assertion +withRawResult name check = do + fs <- loadRpcFixtures fixturePath + check (requireRpcResult name fs) + +tests :: TestTree +tests = + testGroup + "RPC response parsers (recorded from a live node)" + [ testGroup "cluster and node" clusterTests, + testGroup "ledger and epoch" ledgerTests, + testGroup "blocks" blockTests, + testGroup "tokenomics" tokenomicsTests, + testGroup "accounts" accountTests, + testGroup "transactions" transactionTests, + testGroup "SPL token" tokenTests + ] + +clusterTests :: [TestTree] +clusterTests = + [ testCase "getVersion" $ withResult @SolanaVersion "getVersion" $ \v -> + assertBool "reports a solana-core version" (not (null (solana_core v))), + testCase "getIdentity" $ withResult @NodeIdentity "getIdentity" $ \_ -> + pure (), + testCase "getClusterNodes" $ withResult @[ClusterNodes] "getClusterNodes" $ \nodes -> + assertBool "the local validator lists itself" (not (null nodes)), + testCase "getHealth" $ withResult @String "getHealth" $ \health -> + health @?= "ok", + testCase "getRecentPerformanceSamples" $ withResult @[PerformanceSample] "getRecentPerformanceSamples" $ \samples -> + assertBool "samples cover a non-zero period" (all ((> 0) . samplePeriodSecs) samples) + ] + +ledgerTests :: [TestTree] +ledgerTests = + [ testCase "getEpochInfo" $ withResult @EpochInfo "getEpochInfo" $ \info -> + assertBool "absolute slot is at least the slot index" (absoluteSlot info >= slotIndex info), + testCase "getEpochSchedule" $ withResult @EpochSchedule "getEpochSchedule" $ \schedule -> + assertBool "an epoch spans some slots" (slotsPerEpoch schedule > 0), + testCase "getGenesisHash" $ withResult @BlockHash "getGenesisHash" $ \_ -> + pure (), + testCase "getSlot" $ withResult @Slot "getSlot" $ \slot -> + assertBool "slot advanced past genesis" (slot > 0), + testCase "getBlockHeight" $ withResult @BlockHeight "getBlockHeight" $ \height -> + assertBool "block height advanced past genesis" (height > 0), + testCase "getTransactionCount" $ withRawResult "getTransactionCount" $ \_ -> + pure (), + testCase "getFirstAvailableBlock" $ withResult @Slot "getFirstAvailableBlock" $ \_ -> + pure (), + testCase "getStakeMinimumDelegation" $ withResult @(RPCResponse Lamport) "getStakeMinimumDelegation" $ \r -> + assertBool "context slot is populated" (contextSlot (context r) > 0) + ] + +blockTests :: [TestTree] +blockTests = + [ testCase "getLatestBlockhash" $ withResult @(RPCResponse LatestBlockHash) "getLatestBlockhash" $ \r -> + assertBool "blockhash is valid for some future block" (lastValidBlockHeight (value r) > 0), + testCase "isBlockhashValid" $ withResult @(RPCResponse Bool) "isBlockhashValid" $ \r -> + value r @?= True, + testCase "getBlock" $ withResult @(Maybe BlockInfo) "getBlock" $ \block -> + assertBool "the recorded slot holds a block" (isJust block), + testCase "getBlock carries the recorded transfer" $ withResult @(Maybe BlockInfo) "getBlock" $ \case + Nothing -> assertFailure "expected a block" + Just b -> assertBool "block lists transactions" (not (null (transactionsBI b))), + testCase "getBlockCommitment" $ withResult @BlockCommitment "getBlockCommitment" $ \c -> + assertBool "total stake is positive" (totalStake c > 0), + testCase "getBlockProduction" $ withResult @(RPCResponse BlockProduction) "getBlockProduction" $ \r -> + case value r of + BlockProduction identities _ -> assertBool "at least one leader produced blocks" (not (null identities)), + testCase "getBlocks" $ withResult @[Slot] "getBlocks" $ \slots -> + assertBool "the queried range is non-empty" (not (null slots)) + ] + +tokenomicsTests :: [TestTree] +tokenomicsTests = + [ testCase "getInflationGovernor" $ withResult @InflationGovernor "getInflationGovernor" $ \g -> + assertBool "taper is a fraction" (taper g > 0 && taper g <= 1), + testCase "getInflationRate" $ withResult @InflationRate "getInflationRate" $ \r -> + assertBool "total is validator plus foundation" (abs (totalInflation r - (validatorInflation r + foundationInflation r)) < 1e-9), + testCase "getSupply" $ withResult @(RPCResponse SolanaSupply) "getSupply" $ \r -> + assertBool "total supply covers circulating" (total (value r) >= circulating (value r)), + testCase "getVoteAccounts" $ withResult @VoteAccounts "getVoteAccounts" $ \accounts -> + assertBool "the test validator votes" (not (null (current accounts))), + testCase "getMinimumBalanceForRentExemption" $ withResult @Lamport "getMinimumBalanceForRentExemption" $ \rent -> + assertBool "rent exemption for 165 bytes is non-trivial" (rent > Lamport 1000000) + ] + +accountTests :: [TestTree] +accountTests = + [ testCase "getBalance" $ withResult @(RPCResponse Lamport) "getBalance" $ \r -> + assertBool "the airdropped payer holds SOL" (value r > Lamport 0), + testCase "getAccountInfo" $ withResult @(RPCResponse (Maybe AccountInfo)) "getAccountInfo" $ \r -> + case value r of + Nothing -> assertFailure "expected the payer account to exist" + Just info -> do + assertBool "payer holds lamports" (lamports info > Lamport 0) + executable info @?= False, + -- A node reports an absent account as a null value, not an error; the + -- parser has to model that rather than fail. + testCase "getAccountInfo (missing account)" $ withResult @(RPCResponse (Maybe AccountInfo)) "getAccountInfo-missing" $ \r -> + value r @?= Nothing, + testCase "getMultipleAccounts" $ withResult @(RPCResponse [Maybe AccountInfo]) "getMultipleAccounts" $ \r -> + length (value r) @?= 2, + testCase "getLargestAccounts" $ withResult @(RPCResponse [AddressAndLamports]) "getLargestAccounts" $ \r -> + assertBool "accounts are listed with balances" (not (null (value r)) && all ((> Lamport 0) . RpcAccount.lamports) (value r)), + testCase "getProgramAccounts" $ withResult @[Account] "getProgramAccounts" $ \accounts -> + assertBool "the token program owns the mint and token account" (length accounts >= 2) + ] + +transactionTests :: [TestTree] +transactionTests = + [ testCase "getSignaturesForAddress" $ withResult @[TransactionSignatureInformation] "getSignaturesForAddress" $ \case + [] -> assertFailure "expected the recipient's transfer to be listed" + (s : _) -> do + err s @?= Nothing + assertBool "signature is attributed to a slot" (slotTxSig s > 0), + testCase "getSignatureStatuses" $ withResult @(RPCResponse [Maybe TransactionSignatureStatus]) "getSignatureStatuses" $ \r -> + case value r of + [Just s] -> do + errTxStatus s @?= Nothing + confirmationStatusTxStatus s @?= Just "finalized" + other -> assertFailure ("expected exactly one status, got " <> show (length other)), + testCase "getTransaction" $ withResult @(Maybe TransactionResult) "getTransaction" $ \result -> + assertBool "the recorded transfer is retrievable" (isJust result) + ] + +tokenTests :: [TestTree] +tokenTests = + [ testCase "getTokenSupply" $ withResult @(RPCResponse AmountObject) "getTokenSupply" $ \r -> do + -- The recorder mints 42 tokens at 6 decimals. + amount (value r) @?= "42000000" + decimals (value r) @?= 6 + uiAmountString (value r) @?= "42", + testCase "getTokenAccountBalance" $ withResult @(RPCResponse AmountObject) "getTokenAccountBalance" $ \r -> do + amount (value r) @?= "42000000" + decimals (value r) @?= 6, + testCase "getTokenLargestAccounts" $ withResult @(RPCResponse [AmountObjectWithAddr]) "getTokenLargestAccounts" $ \r -> + case value r of + [] -> assertFailure "expected the minted account to be listed" + (a : _) -> amount' a @?= "42000000", + testCase "getTokenAccountsByOwner" $ withResult @(RPCResponse [Account]) "getTokenAccountsByOwner" $ \r -> + length (value r) @?= 1 + ] diff --git a/test/Test/RPC/WebSocket.hs b/test/Test/RPC/WebSocket.hs new file mode 100644 --- /dev/null +++ b/test/Test/RPC/WebSocket.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Tests for the Solana PubSub (WebSocket) protocol layer. +-- +-- The request goldens and notification payloads below are the canonical +-- examples from the Solana WebSocket RPC documentation, so they pin this +-- module against the documented wire format rather than against our own +-- encoder's habits. +module Test.RPC.WebSocket (tests) where + +import Control.Concurrent.MVar (newEmptyMVar, takeMVar) +import Data.ByteString qualified as BS +import Data.ByteString.Char8 qualified as BS8 +import Data.IORef +import Data.List (isInfixOf) +import Data.Maybe (isJust) +import Network.Solana.Core.Account (AccountData (..), AccountInfo (..), Lamport (..)) +import Network.Solana.Core.Crypto (mkPublicKeyFromString, unsafeSigFromString) +import Network.Solana.RPC.WebSocket +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "Network.Solana.RPC.WebSocket" + [ testGroup "requests" requestTests, + testGroup "incoming messages" parseTests, + testGroup "awaitSignature" awaitTests + ] + +-- | The signature used throughout the Solana WebSocket documentation. +docSignature :: String +docSignature = "2EBVM6cB8vAAD93Ktr6Vd8p67XPbQzCJX47MpReuiCXJAtcjaxpvWpcg9Ege1Nr5Tk3a2GFrByT7WPBjdsTycY9b" + +-- | The account pubkey used in the documented @accountSubscribe@ example. +docPubkey :: String +docPubkey = "CM78CPUeXjn8o3yroDHxUtKsZZgoy4GPkPPXfouKNH12" + +requestTests :: [TestTree] +requestTests = + [ testCase "signatureSubscribe matches the documented request" $ + signatureSubscribeRequest (RequestId 1) (unsafeSigFromString docSignature) (Just "finalized") False + @?= BS8.pack + ( "{\"jsonrpc\":\"2.0\",\"id\":1,\"method\":\"signatureSubscribe\",\"params\":[\"" + <> docSignature + <> "\",{\"commitment\":\"finalized\",\"enableReceivedNotification\":false}]}" + ), + testCase "signatureSubscribe omits commitment when unset and honours the received flag" $ + signatureSubscribeRequest (RequestId 7) (unsafeSigFromString docSignature) Nothing True + @?= BS8.pack + ( "{\"jsonrpc\":\"2.0\",\"id\":7,\"method\":\"signatureSubscribe\",\"params\":[\"" + <> docSignature + <> "\",{\"enableReceivedNotification\":true}]}" + ), + testCase "accountSubscribe matches the documented request" $ do + pk <- either assertFailure' pure (mkPublicKeyFromString docPubkey) + accountSubscribeRequest (RequestId 1) pk (Just "finalized") + @?= BS8.pack + ( "{\"jsonrpc\":\"2.0\",\"id\":1,\"method\":\"accountSubscribe\",\"params\":[\"" + <> docPubkey + <> "\",{\"commitment\":\"finalized\",\"encoding\":\"base64\"}]}" + ), + testCase "signatureUnsubscribe matches the documented request" $ + signatureUnsubscribeRequest (RequestId 1) (SubscriptionId 0) + @?= "{\"jsonrpc\":\"2.0\",\"id\":1,\"method\":\"signatureUnsubscribe\",\"params\":[0]}", + testCase "accountUnsubscribe matches the documented request" $ + accountUnsubscribeRequest (RequestId 1) (SubscriptionId 0) + @?= "{\"jsonrpc\":\"2.0\",\"id\":1,\"method\":\"accountUnsubscribe\",\"params\":[0]}" + ] + +parseTests :: [TestTree] +parseTests = + [ testCase "subscribe acknowledgement carries the subscription id" $ + parseWsMessage "{\"jsonrpc\":\"2.0\",\"result\":23784,\"id\":1}" + @?= Right (SubscribeAck (RequestId 1) (SubscriptionId 23784)), + testCase "unsubscribe acknowledgement is distinguished by its boolean result" $ + parseWsMessage "{\"jsonrpc\":\"2.0\",\"result\":true,\"id\":1}" + @?= Right (UnsubscribeAck (RequestId 1) True), + -- PubSub omits context.apiVersion, unlike the HTTP RPC responses that + -- 'Network.Solana.RPC.HTTP.Types.Context' models; parsing must not + -- require it. + testCase "signature notification without context.apiVersion parses as success" $ + parseWsMessage + "{\"jsonrpc\":\"2.0\",\"method\":\"signatureNotification\",\"params\":{\"result\":{\"context\":{\"slot\":5207624},\"value\":{\"err\":null}},\"subscription\":24006}}" + @?= Right (SignatureNotice (SubscriptionId 24006) (SignatureNotification 5207624 Nothing False)), + testCase "signature notification surfaces an on-chain error" $ + case parseWsMessage + "{\"jsonrpc\":\"2.0\",\"method\":\"signatureNotification\",\"params\":{\"result\":{\"context\":{\"slot\":10},\"value\":{\"err\":{\"InstructionError\":[0,{\"Custom\":1}]}}},\"subscription\":1}}" of + Right (SignatureNotice sub n) -> do + sub @?= SubscriptionId 1 + snSlot n @?= 10 + snReceived n @?= False + assertBool "error preserved" (isJust (snErr n)) + other -> assertFailure ("expected a signature notification, got " <> show other), + testCase "receivedSignature notification is flagged, not treated as terminal" $ + parseWsMessage + "{\"jsonrpc\":\"2.0\",\"method\":\"signatureNotification\",\"params\":{\"result\":{\"context\":{\"slot\":9},\"value\":\"receivedSignature\"},\"subscription\":2}}" + @?= Right (SignatureNotice (SubscriptionId 2) (SignatureNotification 9 Nothing True)), + testCase "account notification decodes into the shared AccountInfo type" $ + case parseWsMessage + "{\"jsonrpc\":\"2.0\",\"method\":\"accountNotification\",\"params\":{\"result\":{\"context\":{\"slot\":5199307},\"value\":{\"data\":[\"AQID\",\"base64\"],\"executable\":false,\"lamports\":33594,\"owner\":\"11111111111111111111111111111111\",\"rentEpoch\":635,\"space\":3}},\"subscription\":23784}}" of + Right (AccountNotice sub n) -> do + sub @?= SubscriptionId 23784 + anSlot n @?= 5199307 + lamports (anAccount n) @?= Lamport 33594 + executable (anAccount n) @?= False + dataField (anAccount n) @?= AccountDataBinary (BS8.pack "\SOH\STX\ETX") + other -> assertFailure ("expected an account notification, got " <> show other), + testCase "JSON-RPC error responses are reported, not silently dropped" $ + parseWsMessage "{\"jsonrpc\":\"2.0\",\"error\":{\"code\":-32602,\"message\":\"Invalid Request\"},\"id\":3}" + @?= Right (WsErrorMessage (Just (RequestId 3)) (-32602) "Invalid Request"), + testCase "JSON-RPC error with a null id is still reported" $ + parseWsMessage "{\"jsonrpc\":\"2.0\",\"error\":{\"code\":-32700,\"message\":\"Parse error\"},\"id\":null}" + @?= Right (WsErrorMessage Nothing (-32700) "Parse error"), + testCase "malformed JSON is rejected" $ + assertBool "expected a Left" (isLeft (parseWsMessage "not json")), + testCase "an unknown notification method is rejected rather than misread" $ + assertBool + "expected a Left" + (isLeft (parseWsMessage "{\"jsonrpc\":\"2.0\",\"method\":\"slotNotification\",\"params\":{\"result\":{\"slot\":1},\"subscription\":1}}")) + ] + +-- | A 'WsTransport' that replays a fixed script of incoming frames and +-- records everything sent, so the confirmation handshake can be driven +-- without a network. Receiving past the end of the script blocks forever, +-- which is how the timeout case is exercised. +scriptedTransport :: [BS.ByteString] -> IO (WsTransport, IORef [BS.ByteString]) +scriptedTransport incoming = do + remaining <- newIORef incoming + sent <- newIORef [] + let recv = do + next <- atomicModifyIORef' remaining (\case [] -> ([], Nothing); (y : ys) -> (ys, Just y)) + maybe (newEmptyMVar >>= takeMVar) pure next + send frame = modifyIORef' sent (<> [frame]) + pure (WsTransport send recv, sent) + +ack :: BS.ByteString +ack = "{\"jsonrpc\":\"2.0\",\"result\":24006,\"id\":1}" + +terminalNotice :: BS.ByteString +terminalNotice = + "{\"jsonrpc\":\"2.0\",\"method\":\"signatureNotification\",\"params\":{\"result\":{\"context\":{\"slot\":5207624},\"value\":{\"err\":null}},\"subscription\":24006}}" + +awaitTests :: [TestTree] +awaitTests = + [ testCase "returns the confirming slot and sends the documented subscribe request" $ do + (transport, sent) <- scriptedTransport [ack, terminalNotice] + result <- awaitSignature transport (RequestId 1) (Just "confirmed") 5 (unsafeSigFromString docSignature) + result @?= Right 5207624 + frames <- readIORef sent + frames @?= [signatureSubscribeRequest (RequestId 1) (unsafeSigFromString docSignature) (Just "confirmed") False], + testCase "reports a transaction that failed on-chain" $ do + (transport, _) <- scriptedTransport + [ ack, + "{\"jsonrpc\":\"2.0\",\"method\":\"signatureNotification\",\"params\":{\"result\":{\"context\":{\"slot\":11},\"value\":{\"err\":{\"InstructionError\":[0,{\"Custom\":1}]}}},\"subscription\":24006}}" + ] + result <- awaitSignature transport (RequestId 1) Nothing 5 (unsafeSigFromString docSignature) + assertBool ("expected an on-chain failure, got " <> show result) (either ("failed on-chain" `isInfixOf`) (const False) result), + testCase "skips other subscriptions' frames and the early receivedSignature" $ do + (transport, _) <- scriptedTransport + [ -- a notification for a subscription we never made + "{\"jsonrpc\":\"2.0\",\"method\":\"signatureNotification\",\"params\":{\"result\":{\"context\":{\"slot\":1},\"value\":{\"err\":null}},\"subscription\":999}}", + -- an acknowledgement for somebody else's request + "{\"jsonrpc\":\"2.0\",\"result\":31337,\"id\":42}", + ack, + -- our own early received notification: seen, but not terminal + "{\"jsonrpc\":\"2.0\",\"method\":\"signatureNotification\",\"params\":{\"result\":{\"context\":{\"slot\":5207600},\"value\":\"receivedSignature\"},\"subscription\":24006}}", + terminalNotice + ] + result <- awaitSignature transport (RequestId 1) (Just "confirmed") 5 (unsafeSigFromString docSignature) + result @?= Right 5207624, + testCase "reports a subscription rejected by the node" $ do + (transport, _) <- scriptedTransport ["{\"jsonrpc\":\"2.0\",\"error\":{\"code\":-32602,\"message\":\"Invalid Request\"},\"id\":1}"] + result <- awaitSignature transport (RequestId 1) Nothing 5 (unsafeSigFromString docSignature) + assertBool ("expected a subscription failure, got " <> show result) (either ("subscription failed" `isInfixOf`) (const False) result), + testCase "reports an unparseable frame instead of hanging" $ do + (transport, _) <- scriptedTransport ["not json"] + result <- awaitSignature transport (RequestId 1) Nothing 5 (unsafeSigFromString docSignature) + assertBool ("expected a parse failure, got " <> show result) (either (const True) (const False) result), + testCase "times out when the node never answers" $ do + (transport, _) <- scriptedTransport [] + result <- awaitSignature transport (RequestId 1) Nothing 1 (unsafeSigFromString docSignature) + assertBool ("expected a timeout, got " <> show result) (either ("timed out" `isInfixOf`) (const False) result) + ] + +isLeft :: Either a b -> Bool +isLeft = either (const True) (const False) + +assertFailure' :: String -> IO a +assertFailure' = assertFailure diff --git a/test/Test/SplPrograms/AssociatedTokenAccount.hs b/test/Test/SplPrograms/AssociatedTokenAccount.hs new file mode 100644 --- /dev/null +++ b/test/Test/SplPrograms/AssociatedTokenAccount.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.SplPrograms.AssociatedTokenAccount (tests) where + +import Data.ByteString qualified as BS +import Network.Solana.Core.Crypto +import Network.Solana.Core.Instruction +import Network.Solana.SplPrograms.AssociatedTokenAccount qualified as Ata +import Network.Solana.SplPrograms.Token qualified as Tok +import Test.Fixtures +import Test.Tasty +import Test.Tasty.HUnit + +mintPk :: SolanaPublicKey +mintPk = unsafeSolanaPublicKeyRaw (replicate 32 12) + +payerPk :: SolanaPublicKey +payerPk = + case createSolanaKeypairFromSeed (BS.replicate 32 1) of + Just (pk, _) -> pk + Nothing -> error "failed to derive payer" + +tests :: TestTree +tests = + withResource (loadFixtures "test/fixtures/pda.json") (const (pure ())) $ \getFixtures -> + testGroup + "Associated Token Account" + [ testCase "getAssociatedTokenAddress matches Rust" $ do + fs <- getFixtures + case Ata.getAssociatedTokenAddress payerPk mintPk of + Nothing -> assertFailure "no ATA derivable" + Just ata -> getSolanaPublicKeyRaw ata @?= requireFixture "ata-address" fs, + testCase "create-idempotent data byte" $ do + case Ata.getAssociatedTokenAddress payerPk mintPk of + Nothing -> assertFailure "no ATA derivable" + Just _ -> + instrData (iData (Ata.createAssociatedTokenAccountIdempotent payerPk payerPk mintPk)) + @?= BS.singleton 1, + testCase "create data byte" $ + instrData (iData (Ata.createAssociatedTokenAccount payerPk payerPk mintPk)) + @?= BS.singleton 0, + testCase "create metas" $ do + fs <- getFixtures + let expectedAta = unsafeSolanaPublicKeyRaw (BS.unpack (requireFixture "ata-address" fs)) + iAccounts (Ata.createAssociatedTokenAccount payerPk payerPk mintPk) + @?= [ AccountMeta {accountPubKey = payerPk, isSigner = True, isWritable = True}, + AccountMeta {accountPubKey = expectedAta, isSigner = False, isWritable = True}, + AccountMeta {accountPubKey = payerPk, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = mintPk, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = Ata.systemProgramRef, isSigner = False, isWritable = False}, + AccountMeta {accountPubKey = Tok.tokenProgramId, isSigner = False, isWritable = False} + ] + ] diff --git a/test/Test/SplPrograms/Memo.hs b/test/Test/SplPrograms/Memo.hs new file mode 100644 --- /dev/null +++ b/test/Test/SplPrograms/Memo.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.SplPrograms.Memo (tests) where + +import Data.ByteString qualified as BS +import Network.Solana.Core.Crypto (SolanaPublicKey, unsafeSolanaPublicKeyRaw) +import Network.Solana.Core.Instruction +import Network.Solana.SplPrograms.Memo qualified as Memo +import Test.Fixtures +import Test.Tasty +import Test.Tasty.HUnit + +signerPk :: SolanaPublicKey +signerPk = unsafeSolanaPublicKeyRaw (replicate 32 4) + +dataOf :: Instruction -> BS.ByteString +dataOf = instrData . iData + +tests :: TestTree +tests = + testGroup + "Memo" + [ testCase "memo data bytes match Rust" $ do + fs <- loadFixtures "test/fixtures/memo_instruction_data.json" + dataOf (Memo.buildMemo "hello-memo" []) @?= requireFixture "memo-data" fs, + testCase "signers become readonly-signer metas" $ + iAccounts (Memo.buildMemo "m" [signerPk]) + @?= [AccountMeta {accountPubKey = signerPk, isSigner = True, isWritable = False}], + testCase "no signers means no account metas" $ + iAccounts (Memo.buildMemo "m" []) @?= [] + ] diff --git a/test/Test/SplPrograms/Token.hs b/test/Test/SplPrograms/Token.hs new file mode 100644 --- /dev/null +++ b/test/Test/SplPrograms/Token.hs @@ -0,0 +1,320 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.SplPrograms.Token (tests) where + +import Data.Binary (decode, decodeOrFail, encode) +import Data.Binary.Get (ByteOffset) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BL +import Data.List (isInfixOf) +import Network.Solana.Core.Crypto (SolanaPublicKey, unsafeSolanaPublicKeyRaw) +import Network.Solana.Core.Instruction (AccountMeta (..), iAccounts) +import Network.Solana.SplPrograms.Token qualified as Tok +import Test.Fixtures +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +ownerKey :: SolanaPublicKey +ownerKey = unsafeSolanaPublicKeyRaw (map fromIntegral [0x8a :: Int, 0x88, 0xe3, 0xdd, 0x74, 0x09, 0xf1, 0x95, 0xfd, 0x52, 0xdb, 0x2d, 0x3c, 0xba, 0x5d, 0x72, 0xca, 0x67, 0x09, 0xbf, 0x1d, 0x94, 0x12, 0x1b, 0xf3, 0x74, 0x88, 0x01, 0xb4, 0x0f, 0x6f, 0x5c]) + +walletPk, delegatePk, mintPk, sig1Pk, sig2Pk, accountPk :: SolanaPublicKey +walletPk = unsafeSolanaPublicKeyRaw (replicate 32 11) +delegatePk = unsafeSolanaPublicKeyRaw (replicate 32 13) +mintPk = unsafeSolanaPublicKeyRaw (replicate 32 12) +sig1Pk = unsafeSolanaPublicKeyRaw (replicate 32 14) +sig2Pk = unsafeSolanaPublicKeyRaw (replicate 32 15) +accountPk = unsafeSolanaPublicKeyRaw (replicate 32 16) + +enc :: Tok.TokenInstruction -> BS.ByteString +enc = BL.toStrict . encode + +genTokenInstruction :: Gen Tok.TokenInstruction +genTokenInstruction = + oneof + [ Tok.InitializeMint <$> arbitrary <*> genPk <*> genMaybePk, + pure Tok.InitializeAccount, + Tok.InitializeMultisig <$> arbitrary, + Tok.Transfer <$> arbitrary, + Tok.Approve <$> arbitrary, + pure Tok.Revoke, + Tok.SetAuthority <$> genAuthType <*> genMaybePk, + Tok.MintTo <$> arbitrary, + Tok.Burn <$> arbitrary, + pure Tok.CloseAccount, + pure Tok.FreezeAccount, + pure Tok.ThawAccount, + Tok.TransferChecked <$> arbitrary <*> arbitrary, + Tok.ApproveChecked <$> arbitrary <*> arbitrary, + Tok.MintToChecked <$> arbitrary <*> arbitrary, + Tok.BurnChecked <$> arbitrary <*> arbitrary, + Tok.InitializeAccount2 <$> genPk, + pure Tok.SyncNative, + Tok.InitializeAccount3 <$> genPk, + Tok.InitializeMultisig2 <$> arbitrary, + Tok.InitializeMint2 <$> arbitrary <*> genPk <*> genMaybePk + ] + where + genPk = unsafeSolanaPublicKeyRaw <$> vectorOf 32 arbitrary + genMaybePk = oneof [pure Nothing, Just <$> genPk] + genAuthType = elements [Tok.MintTokens, Tok.FreezeAuthority, Tok.AccountOwner, Tok.CloseAuthority] + +tests :: TestTree +tests = + testGroup + "SPL Token" + [ withResource (loadFixtures "test/fixtures/token_instruction_data.json") (const (pure ())) $ \getFixtures -> + testGroup + "SPL Token instruction data (golden + properties)" + [ goldenCase getFixtures "InitializeMint-some" (Tok.InitializeMint 6 walletPk (Just delegatePk)), + goldenCase getFixtures "InitializeMint-none" (Tok.InitializeMint 6 walletPk Nothing), + goldenCase getFixtures "InitializeAccount" Tok.InitializeAccount, + goldenCase getFixtures "InitializeMultisig" (Tok.InitializeMultisig 2), + goldenCase getFixtures "Transfer" (Tok.Transfer 1000000), + goldenCase getFixtures "Approve" (Tok.Approve 1000000), + goldenCase getFixtures "Revoke" Tok.Revoke, + goldenCase getFixtures "SetAuthority-some" (Tok.SetAuthority Tok.AccountOwner (Just delegatePk)), + goldenCase getFixtures "SetAuthority-none" (Tok.SetAuthority Tok.CloseAuthority Nothing), + goldenCase getFixtures "SetAuthority-mint-tokens" (Tok.SetAuthority Tok.MintTokens (Just delegatePk)), + goldenCase getFixtures "SetAuthority-freeze" (Tok.SetAuthority Tok.FreezeAuthority Nothing), + goldenCase getFixtures "MintTo" (Tok.MintTo 1000000), + goldenCase getFixtures "Burn" (Tok.Burn 1000000), + goldenCase getFixtures "CloseAccount" Tok.CloseAccount, + goldenCase getFixtures "FreezeAccount" Tok.FreezeAccount, + goldenCase getFixtures "ThawAccount" Tok.ThawAccount, + goldenCase getFixtures "TransferChecked" (Tok.TransferChecked 1000000 6), + goldenCase getFixtures "ApproveChecked" (Tok.ApproveChecked 1000000 6), + goldenCase getFixtures "MintToChecked" (Tok.MintToChecked 1000000 6), + goldenCase getFixtures "BurnChecked" (Tok.BurnChecked 1000000 6), + goldenCase getFixtures "InitializeAccount2" (Tok.InitializeAccount2 walletPk), + goldenCase getFixtures "SyncNative" Tok.SyncNative, + goldenCase getFixtures "InitializeAccount3" (Tok.InitializeAccount3 walletPk), + goldenCase getFixtures "InitializeMultisig2" (Tok.InitializeMultisig2 2), + goldenCase getFixtures "InitializeMint2-some" (Tok.InitializeMint2 6 walletPk (Just delegatePk)), + testCase "transfer metas (single owner)" $ + iAccounts (Tok.transfer accountPk delegatePk walletPk [] 1000000) + @?= [ AccountMeta accountPk False True, + AccountMeta delegatePk False True, + AccountMeta walletPk True False + ], + testCase "transfer metas (multisig)" $ + iAccounts (Tok.transfer accountPk delegatePk walletPk [sig1Pk, sig2Pk] 1000000) + @?= [ AccountMeta accountPk False True, + AccountMeta delegatePk False True, + AccountMeta walletPk False False, + AccountMeta sig1Pk True False, + AccountMeta sig2Pk True False + ], + testCase "transferChecked metas" $ + iAccounts (Tok.transferChecked accountPk mintPk delegatePk walletPk [] 1000000 6) + @?= [ AccountMeta accountPk False True, + AccountMeta mintPk False False, + AccountMeta delegatePk False True, + AccountMeta walletPk True False + ], + testCase "initializeMint metas" $ + iAccounts (Tok.initializeMint mintPk 6 walletPk (Just delegatePk)) + @?= [ AccountMeta mintPk False True, + AccountMeta Tok.rentSysvar False False + ], + testCase "mintTo metas" $ + iAccounts (Tok.mintTo mintPk accountPk walletPk [] 1000000) + @?= [ AccountMeta mintPk False True, + AccountMeta accountPk False True, + AccountMeta walletPk True False + ], + testCase "burn metas" $ + iAccounts (Tok.burn accountPk mintPk walletPk [] 1000000) + @?= [ AccountMeta accountPk False True, + AccountMeta mintPk False True, + AccountMeta walletPk True False + ], + testCase "closeAccount metas" $ + iAccounts (Tok.closeAccount accountPk delegatePk walletPk []) + @?= [ AccountMeta accountPk False True, + AccountMeta delegatePk False True, + AccountMeta walletPk True False + ], + testCase "approve metas" $ + iAccounts (Tok.approve accountPk delegatePk walletPk [] 1000000) + @?= [ AccountMeta accountPk False True, + AccountMeta delegatePk False False, + AccountMeta walletPk True False + ], + testCase "revoke metas" $ + iAccounts (Tok.revoke accountPk walletPk []) + @?= [ AccountMeta accountPk False True, + AccountMeta walletPk True False + ], + testCase "setAuthority metas" $ + iAccounts (Tok.setAuthority mintPk Tok.AccountOwner (Just delegatePk) walletPk []) + @?= [ AccountMeta mintPk False True, + AccountMeta walletPk True False + ], + testCase "initializeAccount metas" $ + iAccounts (Tok.initializeAccount accountPk mintPk walletPk) + @?= [ AccountMeta accountPk False True, + AccountMeta mintPk False False, + AccountMeta walletPk False False, + AccountMeta Tok.rentSysvar False False + ], + testCase "freezeAccount metas" $ + iAccounts (Tok.freezeAccount accountPk mintPk walletPk []) + @?= [ AccountMeta accountPk False True, + AccountMeta mintPk False False, + AccountMeta walletPk True False + ], + testCase "thawAccount metas" $ + iAccounts (Tok.thawAccount accountPk mintPk walletPk []) + @?= [ AccountMeta accountPk False True, + AccountMeta mintPk False False, + AccountMeta walletPk True False + ], + testCase "syncNative metas" $ + iAccounts (Tok.syncNative accountPk) + @?= [AccountMeta accountPk False True], + testCase "initializeMultisig metas" $ + iAccounts (Tok.initializeMultisig accountPk [sig1Pk, sig2Pk] 2) + @?= [ AccountMeta accountPk False True, + AccountMeta Tok.rentSysvar False False, + AccountMeta sig1Pk False False, + AccountMeta sig2Pk False False + ], + testCase "initializeMultisig2 metas" $ + iAccounts (Tok.initializeMultisig2 accountPk [sig1Pk, sig2Pk] 2) + @?= [ AccountMeta accountPk False True, + AccountMeta sig1Pk False False, + AccountMeta sig2Pk False False + ], + testCase "approveChecked metas" $ + iAccounts (Tok.approveChecked accountPk mintPk delegatePk walletPk [] 1000000 6) + @?= [ AccountMeta accountPk False True, + AccountMeta mintPk False False, + AccountMeta delegatePk False False, + AccountMeta walletPk True False + ], + testCase "mintToChecked metas" $ + iAccounts (Tok.mintToChecked mintPk accountPk walletPk [] 1000000 6) + @?= [ AccountMeta mintPk False True, + AccountMeta accountPk False True, + AccountMeta walletPk True False + ], + testCase "burnChecked metas" $ + iAccounts (Tok.burnChecked accountPk mintPk walletPk [] 1000000 6) + @?= [ AccountMeta accountPk False True, + AccountMeta mintPk False True, + AccountMeta walletPk True False + ], + testCase "initializeAccount2 (builder) metas" $ + iAccounts (Tok.initializeAccount2 accountPk mintPk walletPk) + @?= [ AccountMeta accountPk False True, + AccountMeta mintPk False False, + AccountMeta Tok.rentSysvar False False + ], + testCase "initializeAccount3 (builder) metas" $ + iAccounts (Tok.initializeAccount3 accountPk mintPk walletPk) + @?= [ AccountMeta accountPk False True, + AccountMeta mintPk False False + ], + testCase "initializeMint2 (builder) metas" $ + iAccounts (Tok.initializeMint2 mintPk 6 walletPk (Just delegatePk)) + @?= [AccountMeta mintPk False True], + testProperty "Binary round-trip" $ + forAll genTokenInstruction $ \ti -> decode (encode ti) === ti, + testCase "decode fails on unknown discriminant" $ + case decodeOrFail (BL.pack [21]) :: Either (BL.ByteString, ByteOffset, String) (BL.ByteString, ByteOffset, Tok.TokenInstruction) of + Left _ -> pure () + Right _ -> assertFailure "expected decode failure for discriminant 21" + ], + withResource (loadFixtures "test/fixtures/state_fixtures.json") (const (pure ())) $ \getFixtures -> + testGroup + "SPL Token state decoders (golden + rejection)" + [ testCase "decodeTokenAccount: token-account golden" $ do + fs <- getFixtures + let bs = requireFixture "token-account" fs + case Tok.decodeTokenAccount bs of + Left err -> assertFailure $ "decode failed: " <> err + Right ta -> do + Tok.taMint ta @?= unsafeSolanaPublicKeyRaw (replicate 32 12) + Tok.taOwner ta @?= ownerKey + Tok.taAmount ta @?= 5000000 + Tok.taDelegate ta @?= Just (unsafeSolanaPublicKeyRaw (replicate 32 13)) + Tok.taState ta @?= Tok.TokenAccountFrozen + Tok.taIsNative ta @?= Just 2039280 + Tok.taDelegatedAmount ta @?= 1000 + Tok.taCloseAuthority ta @?= Just (unsafeSolanaPublicKeyRaw (replicate 32 20)), + testCase "decodeTokenAccount: token-account-minimal golden" $ do + fs <- getFixtures + let bs = requireFixture "token-account-minimal" fs + case Tok.decodeTokenAccount bs of + Left err -> assertFailure $ "decode failed: " <> err + Right ta -> do + Tok.taMint ta @?= unsafeSolanaPublicKeyRaw (replicate 32 12) + Tok.taOwner ta @?= ownerKey + Tok.taAmount ta @?= 5000000 + Tok.taDelegate ta @?= Nothing + Tok.taState ta @?= Tok.TokenAccountInitialized + Tok.taIsNative ta @?= Nothing + Tok.taDelegatedAmount ta @?= 0 + Tok.taCloseAuthority ta @?= Nothing, + testCase "decodeMint: mint golden" $ do + fs <- getFixtures + let bs = requireFixture "mint" fs + case Tok.decodeMint bs of + Left err -> assertFailure $ "decode failed: " <> err + Right m -> do + Tok.mMintAuthority m @?= Just ownerKey + Tok.mSupply m @?= 1000000000 + Tok.mDecimals m @?= 6 + Tok.mIsInitialized m @?= True + Tok.mFreezeAuthority m @?= Just (unsafeSolanaPublicKeyRaw (replicate 32 20)), + testCase "decodeMint: mint-minimal golden" $ do + fs <- getFixtures + let bs = requireFixture "mint-minimal" fs + case Tok.decodeMint bs of + Left err -> assertFailure $ "decode failed: " <> err + Right m -> do + Tok.mMintAuthority m @?= Nothing + Tok.mSupply m @?= 1000000000 + Tok.mDecimals m @?= 6 + Tok.mIsInitialized m @?= True + Tok.mFreezeAuthority m @?= Nothing, + testCase "decodeTokenAccount: reject 164 bytes" $ do + let bs = BS.replicate 164 0 + case Tok.decodeTokenAccount bs of + Left err -> assertBool "error message contains length" ("164" `elem` words err) + Right _ -> assertFailure "expected decode failure for 164 bytes", + testCase "decodeTokenAccount: reject 166 bytes" $ do + let bs = BS.replicate 166 0 + case Tok.decodeTokenAccount bs of + Left err -> assertBool "error message contains length" ("166" `elem` words err) + Right _ -> assertFailure "expected decode failure for 166 bytes", + testCase "decodeTokenAccount: reject invalid COption tag" $ do + let bs = BS.replicate 165 0xFF + case Tok.decodeTokenAccount bs of + Left err -> assertBool "error message contains COption tag" ("COption" `isInfixOf` err || "tag" `isInfixOf` err) + Right _ -> assertFailure "expected decode failure for 0xFF bytes", + testCase "decodeMint: reject 81 bytes" $ do + let bs = BS.replicate 81 0 + case Tok.decodeMint bs of + Left err -> assertBool "error message contains length" ("81" `elem` words err) + Right _ -> assertFailure "expected decode failure for 81 bytes", + testCase "decodeMint: reject 83 bytes" $ do + let bs = BS.replicate 83 0 + case Tok.decodeMint bs of + Left err -> assertBool "error message contains length" ("83" `elem` words err) + Right _ -> assertFailure "expected decode failure for 83 bytes", + testCase "decodeMint: reject invalid is_initialized byte" $ do + fs <- getFixtures + let validBS = requireFixture "mint" fs + modifiedBS = BS.concat [BS.take 45 validBS, BS.singleton 0x02, BS.drop 46 validBS] + case Tok.decodeMint modifiedBS of + Left err -> assertBool "error message contains is_initialized" ("is_initialized" `isInfixOf` err) + Right _ -> assertFailure "expected decode failure for invalid is_initialized byte" + ] + ] + where + goldenCase getFixtures name ti = + testCase name $ do + fs <- getFixtures + enc ti @?= requireFixture name fs diff --git a/test/fixtures/alt_instruction_data.json b/test/fixtures/alt_instruction_data.json new file mode 100644 --- /dev/null +++ b/test/fixtures/alt_instruction_data.json @@ -0,0 +1,22 @@ +[ + { + "hex": "000000003930000000000000fe", + "name": "CreateLookupTable" + }, + { + "hex": "01000000", + "name": "FreezeLookupTable" + }, + { + "hex": "0200000002000000000000001d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e", + "name": "ExtendLookupTable" + }, + { + "hex": "03000000", + "name": "DeactivateLookupTable" + }, + { + "hex": "04000000", + "name": "CloseLookupTable" + } +] diff --git a/test/fixtures/compute_budget_instruction_data.json b/test/fixtures/compute_budget_instruction_data.json new file mode 100644 --- /dev/null +++ b/test/fixtures/compute_budget_instruction_data.json @@ -0,0 +1,18 @@ +[ + { + "hex": "0100800000", + "name": "RequestHeapFrame" + }, + { + "hex": "02400d0300", + "name": "SetComputeUnitLimit" + }, + { + "hex": "03e803000000000000", + "name": "SetComputeUnitPrice" + }, + { + "hex": "0400000100", + "name": "SetLoadedAccountsDataSizeLimit" + } +] diff --git a/test/fixtures/loader_instruction_data.json b/test/fixtures/loader_instruction_data.json new file mode 100644 --- /dev/null +++ b/test/fixtures/loader_instruction_data.json @@ -0,0 +1,34 @@ +[ + { + "hex": "00000000", + "name": "InitializeBuffer" + }, + { + "hex": "01000000800000004000000000000000abababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababab", + "name": "Write" + }, + { + "hex": "020000000000100000000000", + "name": "DeployWithMaxDataLen" + }, + { + "hex": "03000000", + "name": "Upgrade" + }, + { + "hex": "04000000", + "name": "SetAuthority" + }, + { + "hex": "05000000", + "name": "Close" + }, + { + "hex": "0600000000100000", + "name": "ExtendProgram" + }, + { + "hex": "07000000", + "name": "SetAuthorityChecked" + } +] diff --git a/test/fixtures/memo_instruction_data.json b/test/fixtures/memo_instruction_data.json new file mode 100644 --- /dev/null +++ b/test/fixtures/memo_instruction_data.json @@ -0,0 +1,6 @@ +[ + { + "hex": "68656c6c6f2d6d656d6f", + "name": "memo-data" + } +] diff --git a/test/fixtures/messages.json b/test/fixtures/messages.json new file mode 100644 --- /dev/null +++ b/test/fixtures/messages.json @@ -0,0 +1,10 @@ +[ + { + "hex": "010001038a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c02020202020202020202020202020202020202020202020202020202020202020000000000000000000000000000000000000000000000000000000000000000090909090909090909090909090909090909090909090909090909090909090901020200010c0200000000ca9a3b00000000", + "name": "transfer-message" + }, + { + "hex": "010001038a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c02020202020202020202020202020202020202020202020202020202020202020000000000000000000000000000000000000000000000000000000000000000090909090909090909090909090909090909090909090909090909090909090902020200010c0200000000ca9a3b000000000201000c08000000c800000000000000", + "name": "transfer-allocate-message" + } +] diff --git a/test/fixtures/metadata_instruction_data.json b/test/fixtures/metadata_instruction_data.json new file mode 100644 --- /dev/null +++ b/test/fixtures/metadata_instruction_data.json @@ -0,0 +1,61 @@ +[ + { + "hex": "2112000000536f6c616e61204861736b656c6c204e465405000000534853444b1c00000068747470733a2f2f6578616d706c652e636f6d2f6e66742e6a736f6e260201020000008a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c013c212121212121212121212121212121212121212121212121212121212121212100280100222222222222222222222222222222222222222222222222222222222222222201010a000000000000000a000000000000000101000000000000000000", + "name": "CreateMetadataAccountV3-full" + }, + { + "hex": "2112000000536f6c616e61204861736b656c6c204e465405000000534853444b1c00000068747470733a2f2f6578616d706c652e636f6d2f6e66742e6a736f6e26020000000100", + "name": "CreateMetadataAccountV3-minimal" + }, + { + "hex": "0f0112000000536f6c616e61204861736b656c6c204e465405000000534853444b1c00000068747470733a2f2f6578616d706c652e636f6d2f6e66742e6a736f6e260201020000008a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c013c212121212121212121212121212121212121212121212121212121212121212100280100222222222222222222222222222222222222222222222222222222222222222201010a000000000000000a00000000000000018a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c01010101", + "name": "UpdateMetadataAccountV2-some" + }, + { + "hex": "0f00000000", + "name": "UpdateMetadataAccountV2-none" + }, + { + "hex": "11016400000000000000", + "name": "CreateMasterEditionV3-some" + }, + { + "hex": "1100", + "name": "CreateMasterEditionV3-none" + }, + { + "accounts": [ + { + "pubkey": "56a9c8b183e68c0582ef458b28a9f28894971e5aa21bd380aa210f6824f6ea89", + "signer": false, + "writable": true + }, + { + "pubkey": "0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c", + "signer": false, + "writable": false + }, + { + "pubkey": "8a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c", + "signer": true, + "writable": false + }, + { + "pubkey": "8a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c", + "signer": true, + "writable": true + }, + { + "pubkey": "8a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c", + "signer": true, + "writable": false + }, + { + "pubkey": "0000000000000000000000000000000000000000000000000000000000000000", + "signer": false, + "writable": false + } + ], + "name": "create-v3-full-accounts" + } +] diff --git a/test/fixtures/pda.json b/test/fixtures/pda.json new file mode 100644 --- /dev/null +++ b/test/fixtures/pda.json @@ -0,0 +1,42 @@ +[ + { + "hex": "8642e4d3a0e598c38a1973a5b357ec0e42aeae1c3b39c4120c7d5a822caa5d98", + "name": "generic-pda-address" + }, + { + "hex": "fc", + "name": "generic-pda-bump" + }, + { + "hex": "4795b40be0d30fa6202595ebcb06c94d134885ba92d230a6a77ca2aa035a7c05", + "name": "ata-address" + }, + { + "hex": "fe", + "name": "ata-bump" + }, + { + "hex": "6efe5d2accdbecfa532915bef37b76201a30d63af47e53dd1879b0d9acbdd5c9", + "name": "dest-ata-address" + }, + { + "hex": "aca38e9d399501ebcc6c1e29c009874293d8d7f05250ef64a4cf62f9ac282b21", + "name": "programdata-address" + }, + { + "hex": "59379caaad88710221975f8e4519c1f6f471825269818cd96ee5c14ea20adeba", + "name": "lookup-table-address" + }, + { + "hex": "fe", + "name": "lookup-table-bump" + }, + { + "hex": "56a9c8b183e68c0582ef458b28a9f28894971e5aa21bd380aa210f6824f6ea89", + "name": "metadata-address" + }, + { + "hex": "a8b0140612ffc013e3300b768c9e666c6e1712d945bf6ca2cead99fbaa29c1e7", + "name": "master-edition-address" + } +] diff --git a/test/fixtures/rpc_responses.json b/test/fixtures/rpc_responses.json new file mode 100644 --- /dev/null +++ b/test/fixtures/rpc_responses.json @@ -0,0 +1,1163 @@ +[ + { + "name": "getVersion", + "method": "getVersion", + "response": { + "jsonrpc": "2.0", + "result": { + "feature-set": 3271415109, + "solana-core": "2.1.16" + }, + "id": 1 + } + }, + { + "name": "getIdentity", + "method": "getIdentity", + "response": { + "jsonrpc": "2.0", + "result": { + "identity": "EWEDURnEjTRSa5Uz99Kf3hdThUD8X2Rv7RvMFLSQ1DCm" + }, + "id": 1 + } + }, + { + "name": "getClusterNodes", + "method": "getClusterNodes", + "response": { + "jsonrpc": "2.0", + "result": [ + { + "featureSet": 3271415109, + "gossip": "127.0.0.1:1024", + "pubkey": "EWEDURnEjTRSa5Uz99Kf3hdThUD8X2Rv7RvMFLSQ1DCm", + "pubsub": "127.0.0.1:8900", + "rpc": "127.0.0.1:8899", + "serveRepair": "127.0.0.1:1035", + "shredVersion": 24374, + "tpu": "127.0.0.1:1027", + "tpuForwards": "127.0.0.1:1028", + "tpuForwardsQuic": "127.0.0.1:1034", + "tpuQuic": "127.0.0.1:1033", + "tpuVote": "127.0.0.1:1029", + "tvu": "127.0.0.1:1025", + "version": "2.1.16" + } + ], + "id": 1 + } + }, + { + "name": "getHealth", + "method": "getHealth", + "response": { + "jsonrpc": "2.0", + "result": "ok", + "id": 1 + } + }, + { + "name": "getEpochInfo", + "method": "getEpochInfo", + "response": { + "jsonrpc": "2.0", + "result": { + "absoluteSlot": 41, + "blockHeight": 41, + "epoch": 0, + "slotIndex": 41, + "slotsInEpoch": 432000, + "transactionCount": 45 + }, + "id": 1 + } + }, + { + "name": "getEpochSchedule", + "method": "getEpochSchedule", + "response": { + "jsonrpc": "2.0", + "result": { + "firstNormalEpoch": 0, + "firstNormalSlot": 0, + "leaderScheduleSlotOffset": 432000, + "slotsPerEpoch": 432000, + "warmup": false + }, + "id": 1 + } + }, + { + "name": "getGenesisHash", + "method": "getGenesisHash", + "response": { + "jsonrpc": "2.0", + "result": "SDdtDuPR4GB5dZDmAwuQbYTwP4x3EZcsDN4QvwJQHe4", + "id": 1 + } + }, + { + "name": "getSlot", + "method": "getSlot", + "response": { + "jsonrpc": "2.0", + "result": 41, + "id": 1 + } + }, + { + "name": "getBlockHeight", + "method": "getBlockHeight", + "response": { + "jsonrpc": "2.0", + "result": 41, + "id": 1 + } + }, + { + "name": "getTransactionCount", + "method": "getTransactionCount", + "response": { + "jsonrpc": "2.0", + "result": 45, + "id": 1 + } + }, + { + "name": "getFirstAvailableBlock", + "method": "getFirstAvailableBlock", + "response": { + "jsonrpc": "2.0", + "result": 0, + "id": 1 + } + }, + { + "name": "getRecentPerformanceSamples", + "method": "getRecentPerformanceSamples", + "response": { + "jsonrpc": "2.0", + "result": [], + "id": 1 + }, + "params": [ + 2 + ] + }, + { + "name": "getStakeMinimumDelegation", + "method": "getStakeMinimumDelegation", + "response": { + "jsonrpc": "2.0", + "result": { + "context": { + "apiVersion": "2.1.16", + "slot": 41 + }, + "value": 1000000000 + }, + "id": 1 + } + }, + { + "name": "getLatestBlockhash", + "method": "getLatestBlockhash", + "response": { + "jsonrpc": "2.0", + "result": { + "context": { + "apiVersion": "2.1.16", + "slot": 41 + }, + "value": { + "blockhash": "FZjZju6aDpmcT8AhLTyvt7igyL4cwTRCUsyJNoinpQgS", + "lastValidBlockHeight": 191 + } + }, + "id": 1 + } + }, + { + "name": "isBlockhashValid", + "method": "isBlockhashValid", + "response": { + "jsonrpc": "2.0", + "result": { + "context": { + "apiVersion": "2.1.16", + "slot": 72 + }, + "value": true + }, + "id": 1 + }, + "params": [ + "FZjZju6aDpmcT8AhLTyvt7igyL4cwTRCUsyJNoinpQgS", + { + "commitment": "processed" + } + ] + }, + { + "name": "getBlock", + "method": "getBlock", + "response": { + "jsonrpc": "2.0", + "result": { + "blockHeight": 5, + "blockTime": 1785728550, + "blockhash": "EXVev5y6y5FHypiG2c1QmQ7WR7jUeU1rwesbfTS8XML3", + "parentSlot": 4, + "previousBlockhash": "4phmBxWpU7uba3moNmwyDKbH1iADu4zsUUKHbXyVbqfx", + "transactions": [ + { + "meta": { + "computeUnitsConsumed": 2100, + "err": null, + "fee": 10000, + "innerInstructions": [], + "loadedAddresses": { + "readonly": [], + "writable": [] + }, + "logMessages": [ + "Program Vote111111111111111111111111111111111111111 invoke [1]", + "Program Vote111111111111111111111111111111111111111 success" + ], + "postBalances": [ + 499999977500, + 1000000000000000, + 1 + ], + "postTokenBalances": [], + "preBalances": [ + 499999987500, + 1000000000000000, + 1 + ], + "preTokenBalances": [], + "rewards": null, + "status": { + "Ok": null + } + }, + "transaction": { + "message": { + "accountKeys": [ + "EWEDURnEjTRSa5Uz99Kf3hdThUD8X2Rv7RvMFLSQ1DCm", + "3nsvie2PSWMWitUgkKNzKqzaFEUhGahKW51HhR8ThqTc", + "Vote111111111111111111111111111111111111111" + ], + "header": { + "numReadonlySignedAccounts": 0, + "numReadonlyUnsignedAccounts": 1, + "numRequiredSignatures": 2 + }, + "instructions": [ + { + "accounts": [ + 1, + 1 + ], + "data": "FMkqDfKmbTuLt2xkJs2QxzsZaVMEoSdQwbEzyF2LEjFHRAGq6Q1zFhNzyUNcBvC5DeMjm87vWA6u5RBkg5JD3XA8S9Hwq8fPEo4HS4KUfYx9viFQHaQa7xHLwfbvtP9H", + "programIdIndex": 2, + "stackHeight": null + } + ], + "recentBlockhash": "4phmBxWpU7uba3moNmwyDKbH1iADu4zsUUKHbXyVbqfx" + }, + "signatures": [ + "4h86FydrrWzWxWnFpSBxFhbh8zbuyUcKSXUZa58Pv9Xx97oosuCdrZk5KB67QVhpDtHbwu8JoG3bx7iVW2XQagBm", + "9QCQT8kz1t256TtJbG7iLMKwtagGVgxbY1BubfKjdxWD5RRzqpkozRKJ9zmLNMXyAFRd7nTtMqb1yhMpkRJmxme" + ] + }, + "version": "legacy" + }, + { + "meta": { + "computeUnitsConsumed": 150, + "err": null, + "fee": 5000, + "innerInstructions": [], + "loadedAddresses": { + "readonly": [], + "writable": [] + }, + "logMessages": [ + "Program 11111111111111111111111111111111 invoke [1]", + "Program 11111111111111111111111111111111 success" + ], + "postBalances": [ + 8999995000, + 1000000000, + 1 + ], + "postTokenBalances": [], + "preBalances": [ + 10000000000, + 0, + 1 + ], + "preTokenBalances": [], + "rewards": null, + "status": { + "Ok": null + } + }, + "transaction": { + "message": { + "accountKeys": [ + "6o185vKXeS8D27dPfAKxJ2dNVD8iNjmRpFwdYYk3uSrT", + "HR7KwDBsCkkoe9VPCuZhtwgcJMUMLMgFJb6n9WuLqyop", + "11111111111111111111111111111111" + ], + "header": { + "numReadonlySignedAccounts": 0, + "numReadonlyUnsignedAccounts": 1, + "numRequiredSignatures": 1 + }, + "instructions": [ + { + "accounts": [ + 0, + 1 + ], + "data": "3Bxs3zzLZLuLQEYX", + "programIdIndex": 2, + "stackHeight": null + } + ], + "recentBlockhash": "4phmBxWpU7uba3moNmwyDKbH1iADu4zsUUKHbXyVbqfx" + }, + "signatures": [ + "4xzhXw7xxNCGfC74NKbZNEcr92zWdGviq4GJbksRxdXz2NGYFh8Jzyox5X7trorYyYvKEnPHkfNsAfCQA5KAhFRC" + ] + }, + "version": "legacy" + } + ] + }, + "id": 1 + }, + "params": [ + 5, + { + "encoding": "json", + "maxSupportedTransactionVersion": 0, + "transactionDetails": "full", + "rewards": false + } + ] + }, + { + "name": "getBlockCommitment", + "method": "getBlockCommitment", + "response": { + "jsonrpc": "2.0", + "result": { + "commitment": [ + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 999999997717120 + ], + "totalStake": 999999997717120 + }, + "id": 1 + }, + "params": [ + 5 + ] + }, + { + "name": "getBlockProduction", + "method": "getBlockProduction", + "response": { + "jsonrpc": "2.0", + "result": { + "context": { + "apiVersion": "2.1.16", + "slot": 41 + }, + "value": { + "byIdentity": { + "EWEDURnEjTRSa5Uz99Kf3hdThUD8X2Rv7RvMFLSQ1DCm": [ + 42, + 42 + ] + }, + "range": { + "firstSlot": 0, + "lastSlot": 41 + } + } + }, + "id": 1 + } + }, + { + "name": "getBlocks", + "method": "getBlocks", + "response": { + "jsonrpc": "2.0", + "result": [ + 3, + 4, + 5 + ], + "id": 1 + }, + "params": [ + 3, + 5 + ] + }, + { + "name": "getInflationGovernor", + "method": "getInflationGovernor", + "response": { + "jsonrpc": "2.0", + "result": { + "foundation": 0.05, + "foundationTerm": 7.0, + "initial": 0.08, + "taper": 0.15, + "terminal": 0.015 + }, + "id": 1 + } + }, + { + "name": "getInflationRate", + "method": "getInflationRate", + "response": { + "jsonrpc": "2.0", + "result": { + "epoch": 0, + "foundation": 0.004, + "total": 0.08, + "validator": 0.076 + }, + "id": 1 + } + }, + { + "name": "getSupply", + "method": "getSupply", + "response": { + "jsonrpc": "2.0", + "result": { + "context": { + "apiVersion": "2.1.16", + "slot": 41 + }, + "value": { + "circulating": 503000508500862375, + "nonCirculating": 0, + "nonCirculatingAccounts": [ + "8W58E8JVJjH1jCy5CeHJQgvwFXTyAVyesuXRZGbcSUGG", + "DrKzW5koKSZp4mg4BdHLwr72MMXscd2kTiWgckCvvPXz", + "GmyW1nqYcrw7P7JqrcyP9ivU9hYNbrgZ1r5SYJJH41Fs", + "HbZ5FfmKWNHC7uwk6TF1hVi6TCs7dtYfdjEcuPGgzFAg", + "nGME7HgBT6tAJN1f6YuCCngpqT5cvSTndZUVLjQ4jwA", + "2WWb1gRzuXDd5viZLQF7pNRR6Y7UiyeaPpaL35X6j3ve", + "3ZrsTmNM6AkMcqFfv3ryfhQ2jMfqP64RQbqVyAaxqhrQ", + "CzAHrrrHKx9Lxf6wdCMrsZkLvk74c7J2vGv8VYPUmY6v", + "6o5v1HC7WhBnLfRHp8mQTtCP2khdXXjhuyGyYEoy2Suy", + "5khMKAcvmsFaAhoKkdg3u5abvKsmjUQNmhTNP624WB1F", + "4vuWt1oHRqLMhf8Nv1zyEXZsYaeK7dipwrfKLoYU9Riq", + "EMhn1U3TMimW3bvWYbPUvN2eZnCfsuBN4LGWhzzYhiWR", + "Ep5Y58PaSyALPrdFxDVAdfKtVdP55vApvsWjb3jSmXsG", + "HQJtLqvEGGxgNYfRXUurfxV8E1swvCnsbC3456ik27HY", + "5D5NxsNVTgXHyVziwV7mDFwVDS6voaBsyyGxUbhQrhNW", + "GdnSyH3YtwcxFvQrVVJMm1JhTS4QVX7MFsX56uJLUfiZ", + "EMAY24PrS6rWfvpqffFCsTsFJypeeYYmtUc26wdh3Wup", + "P8aKfWQPeRnsZtpBrwWTYzyAoRk74KMz56xc6NEpC4J", + "GpxpMVhrBBBEYbEJxdR62w3daWz444V7m6dxYDZKH77D", + "8rT45mqpuDBR1vcnDc9kwP9DrZAXDR4ZeuKWw3u1gTGa", + "AsrYX4FeLXnZcrjcZmrASY2Eq1jvEeQfwxtNTxS5zojA", + "14FUT96s9swbmH7ZjpDvfEDywnAYy9zaNhv4xvezySGu", + "8pNBEppa1VcFAsx4Hzq9CpdXUXZjUXbvQwLX2K7QsCwb", + "CsUqV42gVQLJwQsKyjWHqGkfHarxn9hcY4YeSjgaaeTd", + "9S2M3UYPpnPZTBtbcUvehYmiWFK3kBhwfzV2iWuwvaVy", + "Ab1UcdsFXZVnkSt1Z3vcYU65GQk5MvCbs54SviaiaqHb", + "CY7X5o3Wi2eQhTocLmUS6JSWyx1NinBfW7AXRrkRCpi8", + "GK8R4uUmrawcREZ5xJy5dAzVV5V7aFvYg77id37pVTK", + "9xbcBZoGYFnfJZe81EDuDYKUm8xGkjzW8z4EgnVhNvsv", + "HuqDWJodFhAEWh6aWdsDVUqsjRket5DYXMYyDYtD8hdN", + "3itU5ME8L6FDqtMiRoUiT1F7PwbkTtHBbW51YWD5jtjm", + "5PLJZLJiRR9vf7d1JCCg7UuWjtyN9nkab9uok6TqSyuP", + "CUageMFi49kzoDqtdU8NvQ4Bq3sbtJygjKDAXJ45nmAi", + "4pV47TiPzZ7SSBPHmgUvSLmH9mMSe8tjyPhQZGbi1zPC", + "CVgyXrbEd1ctEuvq11QdpnCQVnPit8NLdhyqXQHLprM2", + "5XdtyEDREHJXXW1CTtCsVjJRjBapAwK78ZquzvnNVRrV", + "BsKsunvENxAraBrL77UfAn1Gi7unVEmQAdCbhsjUN6tU", + "7Np41oeYqPefeNQEHSv1UDhYrehxin3NStELsSKCT4K2", + "5q54XjQ7vDx4y6KphPeE97LUNiYGtP55spjvXAWPGBuf", + "3fV2GaDKa3pZxyDcpMh5Vrh2FVAMUiWUKbYmnBFv8As3", + "Dc2oHxFXQaC2QfLStuU7txtD3U5HZ82MrCSGDooWjbsv", + "3iPvAS4xdhYr6SkhVDHCLr7tJjMAFK4wvvHWJxFQVg15", + "Br3aeVGapRb2xTq17RU2pYZCoJpWA7bq6TKBCcYtMSmt", + "6yKHERk8rsbmJxvMpPuwPs1ct3hRiP7xaJF2tvnGU6nK", + "7Y8smnoUrYKGGuDq2uaFKVxJYhojgg7DVixHyAtGTYEV", + "GvpCiTgq9dmEeojCDBivoLoZqc4AkbUDACpqPMwYLWKh", + "CakcnaRDHka2gXyfbEd2d3xsvkJkqsLw2akB3zsN1D2S", + "8vqrX3H2BYLaXVintse3gorPEM4TgTwTFZNN1Fm9TdYs", + "3bTGcGB9F98XxnrBNftmmm48JGfPgi5sYxDEKiCjQYk3", + "BUnRE27mYXN9p8H1Ay24GXhJC88q2CuwLoNU2v2CrW4W", + "GEWSkfWgHkpiLbeKaAnwvqnECGdRNf49at5nFccVey7c", + "8ndGYFjav6NDXvzYcxs449Aub3AxYv4vYpk89zRDwgj7", + "CuatS6njAcfkFHnvai7zXCs7syA9bykXWsDCJEWfhjHG", + "AG3m2bAibcY8raMt4oXEGqRHwX4FWKPPJVjZxn1LySDX", + "GumSE5HsMV5HCwBTv2D2D81yy9x17aDkvobkqAfTRgmo", + "FwfaykN7ACnsEUDHANzGHqTGQZMcGnUSsahAHUqbdPrz", + "F9MWFw8cnYVwsRq8Am1PGfFL3cQUZV37mbGoxZftzLjN", + "BUjkdqUuH5Lz9XzcMcR4DdEMnFG6r8QzUMBm16Rfau96", + "C7C8odR8oashR5Feyrq2tJKaXL18id1dSj2zbkDGL2C2", + "CHmdL15akDcJgBkY6BP3hzs98Dqr6wbdDC5p8odvtSbq", + "FR84wZQy3Y3j2gWz6pgETUiUoJtreMEuWfbg6573UCj9", + "8CUUMKYNGxdgYio5CLHRHyzMEhhVRMcqefgE6dLqnVRK", + "AzHQ8Bia1grVVbcGyci7wzueSWkgvu7YZVZ4B9rkL5P6", + "63DtkW7zuARcd185EmHAkfF44bDcC2SiTSEj2spLP3iA", + "xQadXQiUTCCFhfHjvQx1hyJK6KVWr1w2fD6DT3cdwj7", + "HUAkU5psJXZuw54Lrg1ksbXzHv2fzczQ9sNbmisVMeJU", + "AVYpwVou2BhdLivAwLxKPALZQsY7aZNkNmGbP2fZw7RU", + "CWeRmXme7LmbaUWTZWFLt6FMnpzLCHaQLuR2TdgFn4Lq", + "Fg12tB1tz8w6zJSQ4ZAGotWoCztdMJF9hqK8R11pakog", + "6nN69B4uZuESZYxr9nrLDjmKRtjDZQXrehwkfQTKw62U", + "FiWYY85b58zEEcPtxe3PuqzWPjqBJXqdwgZeqSBmT9Cn", + "HCV5dGFJXRrJ3jhDYA4DCeb9TEDTwGGYXtT3wHksu2Zr", + "GNiz4Mq886bTNDT3pijGsu2gbw6it7sqrwncro45USeB", + "GK2zqSsXLA2rwVZk347RYhh6jJpRsCA69FjLW93ZGi3B", + "4sxwau4mdqZ8zEJsfryXq4QFYnMJSCp3HWuZQod8WU5k", + "H3Ni7vG1CsmJZdTvxF7RkAf9UM5qk4RsohJsmPvtZNnu", + "7cvkjYAkUYs4W8XcXsca7cBrEGFeSUjeZmKoNBvEwyri", + "Hz9nydgN1k15wnwffKX7CSmZp4VFTnTwLXAEdomFGNXy", + "H1rt8KvXkNhQExTRfkY8r9wjZbZ8yCih6J4wQ5Fz9HGP", + "Es13uD2p64UVPFpEWfDtd6SERdoNR2XVgqBQBZcZSLqW", + "E8jcgWvrvV7rwYHJThwfiBeQ8VAH4FgNEEMG9aAuCMAq", + "AzVV9ZZDxTgW4wWfJmsG6ytaHpQGSe1yz76Nyy84VbQF", + "Mc5XB47H3DKJHym5RLa9mPzWv5snERsF3KNv5AauXK8", + "9huDUZfxoJ7wGMTffUE7vh1xePqef7gyrLJu9NApncqA", + "CND6ZjRTzaCFVdX7pSSWgjTfHZuhxqFDoUBqWBJguNoA", + "JCwT5Ygmq3VeBEbDjL8s8E82Ra2rP9bq45QfZE7Xyaq7", + "7xJ9CLtEAcEShw9kW2gSoZkRWL566Dg12cvgzANJwbTr", + "DE1bawNcRJB9rVm3buyMVfr8mBEoyyu73NBovf2oXJsJ", + "EziVYi3Sv5kJWxmU77PnbrT8jmkVuqwdiFLLzZpLVEn7", + "Eyr9P5XsjK2NUKNCnfu39eqpGoiLFgVAv1LSQgMZCwiQ", + "CQDYc4ET2mbFhVpgj41gXahL6Exn5ZoPcGAzSHuYxwmE", + "DQQGPtj7pphPHCLzzBuEyDDQByUcKGrsJdsH7SP3hAug", + "3o6xgkJ9sTmDeQWyfj3sxwon18fXJB9PV5LDc8sfgR4a", + "Hm9JW7of5i9dnrboS8pCUCSeoQUPh7JsP1rkbJnW7An4", + "BhvLngiqqKeZ8rpxch2uGjeCiC88zzewoWPRuoxpp1aS", + "BuCEvc9ze8UoAQwwsQLy8d447C8sA4zeVtVpc6m5wQeS", + "GhsotwFMH6XUrRLJCxcx62h7748N2Uq8mf87hUGkmPhg", + "8UVjvYyoqP6sqcctTso3xpCdCfgTMiv3VRh7vraC2eJk", + "8DE8fqPfv1fp9DHyGyDFFaMjpopMgDeXspzoi9jpBJjC", + "HKJgYGTTYYR2ZkfJKHbn58w676fKueQXmvbtpyvrSM3N", + "3jnknRabs7G2V9dKhxd2KP85pNWXKXiedYnYxtySnQMs", + "Fgyh8EeYGZtbW8sS33YmNQnzx54WXPrJ5KWNPkCfWPot", + "5smrYwb1Hr2T8XMnvsqccTgXxuqQs14iuE8RbHFYf2Cf", + "6zw7em7uQdmMpuS9fGz8Nq9TLHa5YQhEKKwPjo5PwDK4", + "9hknftBZAQL4f48tWfk3bUEV5YSLcYYtDRqNmpNnhCWG", + "DUS1KxwUhUyDKB4A81E8vdnTe3hSahd92Abtn9CXsEcj", + "GLUmCeJpXB8veNcchPwibkRYwCwvQbKodex5mEjrgToi", + "EAJJD6nDqtXcZ4DnQb19F9XEz8y8bRDHxbWbahatZNbL", + "GpYnVDgB7dzvwSgsjQFeHznjG6Kt1DLBFYrKxjGU1LuD", + "CTvhdUVf8KNyMbyEdnvRrBCHJjBKtQwkbj6zwoqcEssG" + ], + "total": 503000508500862375 + } + }, + "id": 1 + } + }, + { + "name": "getVoteAccounts", + "method": "getVoteAccounts", + "response": { + "jsonrpc": "2.0", + "result": { + "current": [ + { + "activatedStake": 999999997717120, + "commission": 0, + "epochCredits": [ + [ + 0, + 144, + 0 + ] + ], + "epochVoteAccount": true, + "lastVote": 40, + "nodePubkey": "EWEDURnEjTRSa5Uz99Kf3hdThUD8X2Rv7RvMFLSQ1DCm", + "rootSlot": 9, + "votePubkey": "3nsvie2PSWMWitUgkKNzKqzaFEUhGahKW51HhR8ThqTc" + } + ], + "delinquent": [] + }, + "id": 1 + } + }, + { + "name": "getMinimumBalanceForRentExemption", + "method": "getMinimumBalanceForRentExemption", + "response": { + "jsonrpc": "2.0", + "result": 2039280, + "id": 1 + }, + "params": [ + 165 + ] + }, + { + "name": "getBalance", + "method": "getBalance", + "response": { + "jsonrpc": "2.0", + "result": { + "context": { + "apiVersion": "2.1.16", + "slot": 41 + }, + "value": 8996474120 + }, + "id": 1 + }, + "params": [ + "6o185vKXeS8D27dPfAKxJ2dNVD8iNjmRpFwdYYk3uSrT" + ] + }, + { + "name": "getAccountInfo", + "method": "getAccountInfo", + "response": { + "jsonrpc": "2.0", + "result": { + "context": { + "apiVersion": "2.1.16", + "slot": 41 + }, + "value": { + "data": [ + "", + "base64" + ], + "executable": false, + "lamports": 8996474120, + "owner": "11111111111111111111111111111111", + "rentEpoch": 18446744073709551615, + "space": 0 + } + }, + "id": 1 + }, + "params": [ + "6o185vKXeS8D27dPfAKxJ2dNVD8iNjmRpFwdYYk3uSrT", + { + "encoding": "base64" + } + ] + }, + { + "name": "getAccountInfo-missing", + "method": "getAccountInfo", + "response": { + "jsonrpc": "2.0", + "result": { + "context": { + "apiVersion": "2.1.16", + "slot": 41 + }, + "value": null + }, + "id": 1 + }, + "params": [ + "11111111111111111111111111111112", + { + "encoding": "base64" + } + ] + }, + { + "name": "getMultipleAccounts", + "method": "getMultipleAccounts", + "response": { + "jsonrpc": "2.0", + "result": { + "context": { + "apiVersion": "2.1.16", + "slot": 41 + }, + "value": [ + { + "data": [ + "", + "base64" + ], + "executable": false, + "lamports": 8996474120, + "owner": "11111111111111111111111111111111", + "rentEpoch": 18446744073709551615, + "space": 0 + }, + { + "data": [ + "", + "base64" + ], + "executable": false, + "lamports": 1000000000, + "owner": "11111111111111111111111111111111", + "rentEpoch": 18446744073709551615, + "space": 0 + } + ] + }, + "id": 1 + }, + "params": [ + [ + "6o185vKXeS8D27dPfAKxJ2dNVD8iNjmRpFwdYYk3uSrT", + "HR7KwDBsCkkoe9VPCuZhtwgcJMUMLMgFJb6n9WuLqyop" + ], + { + "encoding": "base64" + } + ] + }, + { + "name": "getLargestAccounts", + "method": "getLargestAccounts", + "response": { + "jsonrpc": "2.0", + "result": { + "context": { + "apiVersion": "2.1.16", + "slot": 41 + }, + "value": [ + { + "address": "594C9C199Zp8fK2zvmXrSveE359gijrM6tsoZLYk9obv", + "lamports": 500000000000000000 + }, + { + "address": "BxqNA9vLoWDNiEBzZ4na79hBvUUke2jfTXiki4sfr5J4", + "lamports": 1000000000000000 + }, + { + "address": "3nsvie2PSWMWitUgkKNzKqzaFEUhGahKW51HhR8ThqTc", + "lamports": 1000000000000000 + }, + { + "address": "D758ERd8UUz83zLzxG2ykpTGSWog3HFjST7Bu1nd3bPm", + "lamports": 999989999995000 + }, + { + "address": "EWEDURnEjTRSa5Uz99Kf3hdThUD8X2Rv7RvMFLSQ1DCm", + "lamports": 499999815000 + }, + { + "address": "6o185vKXeS8D27dPfAKxJ2dNVD8iNjmRpFwdYYk3uSrT", + "lamports": 8996474120 + }, + { + "address": "DoU57AYuPFu2QU514RktNPG22QhApEjnKxnBcu4BHDTY", + "lamports": 3773078640 + }, + { + "address": "HR7KwDBsCkkoe9VPCuZhtwgcJMUMLMgFJb6n9WuLqyop", + "lamports": 1000000000 + }, + { + "address": "So11111111111111111111111111111111111111112", + "lamports": 1000000000 + }, + { + "address": "TokenkegQfeZyiNwAJbNbGKPFXCWuBvf9Ss623VQ5DA", + "lamports": 929020800 + }, + { + "address": "SysvarS1otHistory11111111111111111111111111", + "lamports": 913326000 + }, + { + "address": "ATokenGPvbdGVxr1b2hvZbsiqW5xWH25efTNsLJA8knL", + "lamports": 731913600 + }, + { + "address": "MemoSq4gqABAXKb96qnH8TysNcWxMyWCqXgDLGmfcHr", + "lamports": 521498880 + }, + { + "address": "SysvarS1otHashes111111111111111111111111111", + "lamports": 143487360 + }, + { + "address": "Memo1UhkJRfHyvLMcVucJwxXeuD728EqVDDwQDxFMNo", + "lamports": 119712000 + }, + { + "address": "SysvarStakeHistory1111111111111111111111111", + "lamports": 114979200 + }, + { + "address": "SysvarRecentB1ockHashes11111111111111111111", + "lamports": 42706560 + }, + { + "address": "B2kGD5aSJLL8yHUUC8v7VWWyF6DRN6m2kpjhiPin53oe", + "lamports": 2039280 + }, + { + "address": "nsAeRzrkWAUJkGnTnnx1nhr3DokGui17CLUNuEwnoaw", + "lamports": 1461600 + }, + { + "address": "SysvarC1ock11111111111111111111111111111111", + "lamports": 1169280 + } + ] + }, + "id": 1 + } + }, + { + "name": "getProgramAccounts", + "method": "getProgramAccounts", + "response": { + "jsonrpc": "2.0", + "result": [ + { + "account": { + "data": [ + "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAJAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA==", + "base64" + ], + "executable": false, + "lamports": 1000000000, + "owner": "TokenkegQfeZyiNwAJbNbGKPFXCWuBvf9Ss623VQ5DA", + "rentEpoch": 1, + "space": 82 + }, + "pubkey": "So11111111111111111111111111111111111111112" + }, + { + "account": { + "data": [ + "AQAAAFYTSjtFgV37DhAKCpVZ7UaTRdOtkDEDLd/1PcZokXcYgN6AAgAAAAAGAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA==", + "base64" + ], + "executable": false, + "lamports": 1461600, + "owner": "TokenkegQfeZyiNwAJbNbGKPFXCWuBvf9Ss623VQ5DA", + "rentEpoch": 18446744073709551615, + "space": 82 + }, + "pubkey": "nsAeRzrkWAUJkGnTnnx1nhr3DokGui17CLUNuEwnoaw" + }, + { + "account": { + "data": [ + "C7/cEE+JL6u+L/IR/d1bk+Y8tafJlr26pB6MKVNffjBWE0o7RYFd+w4QCgqVWe1Gk0XTrZAxAy3f9T3GaJF3GIDegAIAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA", + "base64" + ], + "executable": false, + "lamports": 2039280, + "owner": "TokenkegQfeZyiNwAJbNbGKPFXCWuBvf9Ss623VQ5DA", + "rentEpoch": 18446744073709551615, + "space": 165 + }, + "pubkey": "B2kGD5aSJLL8yHUUC8v7VWWyF6DRN6m2kpjhiPin53oe" + } + ], + "id": 1 + }, + "params": [ + "TokenkegQfeZyiNwAJbNbGKPFXCWuBvf9Ss623VQ5DA", + { + "encoding": "base64" + } + ] + }, + { + "name": "getSignaturesForAddress", + "method": "getSignaturesForAddress", + "response": { + "jsonrpc": "2.0", + "result": [ + { + "blockTime": 1785728550, + "confirmationStatus": "finalized", + "err": null, + "memo": null, + "signature": "4xzhXw7xxNCGfC74NKbZNEcr92zWdGviq4GJbksRxdXz2NGYFh8Jzyox5X7trorYyYvKEnPHkfNsAfCQA5KAhFRC", + "slot": 5 + } + ], + "id": 1 + }, + "params": [ + "HR7KwDBsCkkoe9VPCuZhtwgcJMUMLMgFJb6n9WuLqyop", + { + "limit": 3 + } + ] + }, + { + "name": "getSignatureStatuses", + "method": "getSignatureStatuses", + "response": { + "jsonrpc": "2.0", + "result": { + "context": { + "apiVersion": "2.1.16", + "slot": 72 + }, + "value": [ + { + "confirmationStatus": "finalized", + "confirmations": null, + "err": null, + "slot": 5, + "status": { + "Ok": null + } + } + ] + }, + "id": 1 + }, + "params": [ + [ + "4xzhXw7xxNCGfC74NKbZNEcr92zWdGviq4GJbksRxdXz2NGYFh8Jzyox5X7trorYyYvKEnPHkfNsAfCQA5KAhFRC" + ], + { + "searchTransactionHistory": true + } + ] + }, + { + "name": "getTransaction", + "method": "getTransaction", + "response": { + "jsonrpc": "2.0", + "result": { + "blockTime": 1785728550, + "meta": { + "computeUnitsConsumed": 150, + "err": null, + "fee": 5000, + "innerInstructions": [], + "loadedAddresses": { + "readonly": [], + "writable": [] + }, + "logMessages": [ + "Program 11111111111111111111111111111111 invoke [1]", + "Program 11111111111111111111111111111111 success" + ], + "postBalances": [ + 8999995000, + 1000000000, + 1 + ], + "postTokenBalances": [], + "preBalances": [ + 10000000000, + 0, + 1 + ], + "preTokenBalances": [], + "rewards": [], + "status": { + "Ok": null + } + }, + "slot": 5, + "transaction": { + "message": { + "accountKeys": [ + "6o185vKXeS8D27dPfAKxJ2dNVD8iNjmRpFwdYYk3uSrT", + "HR7KwDBsCkkoe9VPCuZhtwgcJMUMLMgFJb6n9WuLqyop", + "11111111111111111111111111111111" + ], + "header": { + "numReadonlySignedAccounts": 0, + "numReadonlyUnsignedAccounts": 1, + "numRequiredSignatures": 1 + }, + "instructions": [ + { + "accounts": [ + 0, + 1 + ], + "data": "3Bxs3zzLZLuLQEYX", + "programIdIndex": 2, + "stackHeight": null + } + ], + "recentBlockhash": "4phmBxWpU7uba3moNmwyDKbH1iADu4zsUUKHbXyVbqfx" + }, + "signatures": [ + "4xzhXw7xxNCGfC74NKbZNEcr92zWdGviq4GJbksRxdXz2NGYFh8Jzyox5X7trorYyYvKEnPHkfNsAfCQA5KAhFRC" + ] + }, + "version": "legacy" + }, + "id": 1 + }, + "params": [ + "4xzhXw7xxNCGfC74NKbZNEcr92zWdGviq4GJbksRxdXz2NGYFh8Jzyox5X7trorYyYvKEnPHkfNsAfCQA5KAhFRC", + { + "encoding": "json", + "maxSupportedTransactionVersion": 0 + } + ] + }, + { + "name": "getTokenSupply", + "method": "getTokenSupply", + "response": { + "jsonrpc": "2.0", + "result": { + "context": { + "apiVersion": "2.1.16", + "slot": 41 + }, + "value": { + "amount": "42000000", + "decimals": 6, + "uiAmount": 42.0, + "uiAmountString": "42" + } + }, + "id": 1 + }, + "params": [ + "nsAeRzrkWAUJkGnTnnx1nhr3DokGui17CLUNuEwnoaw" + ] + }, + { + "name": "getTokenAccountBalance", + "method": "getTokenAccountBalance", + "response": { + "jsonrpc": "2.0", + "result": { + "context": { + "apiVersion": "2.1.16", + "slot": 41 + }, + "value": { + "amount": "42000000", + "decimals": 6, + "uiAmount": 42.0, + "uiAmountString": "42" + } + }, + "id": 1 + }, + "params": [ + "B2kGD5aSJLL8yHUUC8v7VWWyF6DRN6m2kpjhiPin53oe" + ] + }, + { + "name": "getTokenLargestAccounts", + "method": "getTokenLargestAccounts", + "response": { + "jsonrpc": "2.0", + "result": { + "context": { + "apiVersion": "2.1.16", + "slot": 41 + }, + "value": [ + { + "address": "B2kGD5aSJLL8yHUUC8v7VWWyF6DRN6m2kpjhiPin53oe", + "amount": "42000000", + "decimals": 6, + "uiAmount": 42.0, + "uiAmountString": "42" + } + ] + }, + "id": 1 + }, + "params": [ + "nsAeRzrkWAUJkGnTnnx1nhr3DokGui17CLUNuEwnoaw" + ] + }, + { + "name": "getTokenAccountsByOwner", + "method": "getTokenAccountsByOwner", + "response": { + "jsonrpc": "2.0", + "result": { + "context": { + "apiVersion": "2.1.16", + "slot": 41 + }, + "value": [ + { + "account": { + "data": [ + "C7/cEE+JL6u+L/IR/d1bk+Y8tafJlr26pB6MKVNffjBWE0o7RYFd+w4QCgqVWe1Gk0XTrZAxAy3f9T3GaJF3GIDegAIAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA", + "base64" + ], + "executable": false, + "lamports": 2039280, + "owner": "TokenkegQfeZyiNwAJbNbGKPFXCWuBvf9Ss623VQ5DA", + "rentEpoch": 18446744073709551615, + "space": 165 + }, + "pubkey": "B2kGD5aSJLL8yHUUC8v7VWWyF6DRN6m2kpjhiPin53oe" + } + ] + }, + "id": 1 + }, + "params": [ + "6o185vKXeS8D27dPfAKxJ2dNVD8iNjmRpFwdYYk3uSrT", + { + "mint": "nsAeRzrkWAUJkGnTnnx1nhr3DokGui17CLUNuEwnoaw" + }, + { + "encoding": "base64" + } + ] + } +] diff --git a/test/fixtures/secp256k1.json b/test/fixtures/secp256k1.json new file mode 100644 --- /dev/null +++ b/test/fixtures/secp256k1.json @@ -0,0 +1,22 @@ +[ + { + "hex": "012000000c000061000a0000b0e5863d0ddf7e105e409fee0ecc0123a362e14b6f4018a4be9555bc3f9879434192f73257b55acabc2d792c99651a9c010b734c01cf890b938bfc154b456453dcdd3115e0b83cc8b08145712a1fbf0b4464233a0068656c6c6f2d73656370", + "name": "secp-full-instruction-data" + }, + { + "hex": "b0e5863d0ddf7e105e409fee0ecc0123a362e14b", + "name": "secp-eth-address" + }, + { + "hex": "6f4018a4be9555bc3f9879434192f73257b55acabc2d792c99651a9c010b734c01cf890b938bfc154b456453dcdd3115e0b83cc8b08145712a1fbf0b4464233a", + "name": "secp-signature" + }, + { + "hex": "00", + "name": "secp-recovery-id" + }, + { + "hex": "68656c6c6f2d73656370", + "name": "secp-message" + } +] diff --git a/test/fixtures/stake_instruction_data.json b/test/fixtures/stake_instruction_data.json new file mode 100644 --- /dev/null +++ b/test/fixtures/stake_instruction_data.json @@ -0,0 +1,54 @@ +[ + { + "hex": "000000008a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c8a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c00f15365000000002c010000000000001212121212121212121212121212121212121212121212121212121212121212", + "name": "Initialize" + }, + { + "hex": "01000000141414141414141414141414141414141414141414141414141414141414141400000000", + "name": "Authorize-staker" + }, + { + "hex": "01000000141414141414141414141414141414141414141414141414141414141414141401000000", + "name": "Authorize-withdrawer" + }, + { + "hex": "02000000", + "name": "DelegateStake" + }, + { + "hex": "0300000090d0030000000000", + "name": "Split" + }, + { + "hex": "0400000020a1070000000000", + "name": "Withdraw" + }, + { + "hex": "05000000", + "name": "Deactivate" + }, + { + "hex": "060000000100f1536500000000012c01000000000000011212121212121212121212121212121212121212121212121212121212121212", + "name": "SetLockup-some" + }, + { + "hex": "06000000000000", + "name": "SetLockup-none" + }, + { + "hex": "07000000", + "name": "Merge" + }, + { + "hex": "09000000", + "name": "InitializeChecked" + }, + { + "hex": "0a00000001000000", + "name": "AuthorizeChecked" + }, + { + "hex": "0d000000", + "name": "GetMinimumDelegation" + } +] diff --git a/test/fixtures/state_fixtures.json b/test/fixtures/state_fixtures.json new file mode 100644 --- /dev/null +++ b/test/fixtures/state_fixtures.json @@ -0,0 +1,46 @@ +[ + { + "hex": "0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c8a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c404b4c0000000000010000000d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0201000000f01d1f0000000000e803000000000000010000001414141414141414141414141414141414141414141414141414141414141414", + "name": "token-account" + }, + { + "hex": "0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c8a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c404b4c0000000000000000000000000000000000000000000000000000000000000000000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000", + "name": "token-account-minimal" + }, + { + "hex": "010000008a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c00ca9a3b000000000601010000001414141414141414141414141414141414141414141414141414141414141414", + "name": "mint" + }, + { + "hex": "00000000000000000000000000000000000000000000000000000000000000000000000000ca9a3b000000000601000000000000000000000000000000000000000000000000000000000000000000000000", + "name": "mint-minimal" + }, + { + "hex": "01000000ffffffffffffffff393000000000000001018a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c000002020202020202020202020202020202020202020202020202020202020202021d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1d1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e1e", + "name": "lookup-table" + }, + { + "hex": "01000000010000008a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c25bdedad9fd7d269184d58d8f80e149acc1ceb154afc3c77363d7859c1febf2e8813000000000000", + "name": "nonce-account" + }, + { + "hex": "25bdedad9fd7d269184d58d8f80e149acc1ceb154afc3c77363d7859c1febf2e", + "name": "nonce-durable-hash" + }, + { + "hex": "0200000080d52200000000008a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c8a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c00f15365000000002c010000000000001212121212121212121212121212121212121212121212121212121212121212111111111111111111111111111111111111111111111111111111111111111140420f0000000000fa00000000000000ffffffffffffffff000000000000d03f2a0000000000000000", + "name": "stake-account" + }, + { + "hex": "0100000080d52200000000008a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c8a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c00f15365000000002c010000000000001212121212121212121212121212121212121212121212121212121212121212", + "name": "stake-account-initialized" + }, + { + "hex": "048a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c20000000536f6c616e61204861736b656c6c204e465400000000000000000000000000000a000000534853444b0000000000c800000068747470733a2f2f6578616d706c652e636f6d2f6e66742e6a736f6e00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000260201020000008a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c013c21212121212121212121212121212121212121212121212121212121212121210028000101fd01000100222222222222222222222222222222222222222222222222222222222222222201010a000000000000000a000000000000000000", + "name": "metadata-account" + }, + { + "hex": "048a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c20000000536f6c616e61204861736b656c6c204e465400000000000000000000000000000a000000534853444b0000000000c800000068747470733a2f2f6578616d706c652e636f6d2f6e66742e6a736f6e00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000260201020000008a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c013c212121212121212121212121212121212121212121212121212121212121212100280001", + "name": "metadata-account-legacy" + } +] diff --git a/test/fixtures/system_instruction_data.json b/test/fixtures/system_instruction_data.json new file mode 100644 --- /dev/null +++ b/test/fixtures/system_instruction_data.json @@ -0,0 +1,54 @@ +[ + { + "hex": "0000000040420f0000000000a5000000000000000505050505050505050505050505050505050505050505050505050505050505", + "name": "CreateAccount" + }, + { + "hex": "010000000505050505050505050505050505050505050505050505050505050505050505", + "name": "Assign" + }, + { + "hex": "0200000040420f0000000000", + "name": "Transfer" + }, + { + "hex": "0300000003030303030303030303030303030303030303030303030303030303030303030a0000000000000068656c6c6f2d7365656440420f0000000000a5000000000000000505050505050505050505050505050505050505050505050505050505050505", + "name": "CreateAccountWithSeed" + }, + { + "hex": "04000000", + "name": "AdvanceNonceAccount" + }, + { + "hex": "0500000040420f0000000000", + "name": "WithdrawNonceAccount" + }, + { + "hex": "060000000606060606060606060606060606060606060606060606060606060606060606", + "name": "InitializeNonceAccount" + }, + { + "hex": "070000000606060606060606060606060606060606060606060606060606060606060606", + "name": "AuthorizeNonceAccount" + }, + { + "hex": "08000000a500000000000000", + "name": "Allocate" + }, + { + "hex": "0900000003030303030303030303030303030303030303030303030303030303030303030a0000000000000068656c6c6f2d73656564a5000000000000000505050505050505050505050505050505050505050505050505050505050505", + "name": "AllocateWithSeed" + }, + { + "hex": "0a00000003030303030303030303030303030303030303030303030303030303030303030a0000000000000068656c6c6f2d736565640505050505050505050505050505050505050505050505050505050505050505", + "name": "AssignWithSeed" + }, + { + "hex": "0b00000040420f00000000000a0000000000000068656c6c6f2d736565640505050505050505050505050505050505050505050505050505050505050505", + "name": "TransferWithSeed" + }, + { + "hex": "0c000000", + "name": "UpgradeNonceAccount" + } +] diff --git a/test/fixtures/token_instruction_data.json b/test/fixtures/token_instruction_data.json new file mode 100644 --- /dev/null +++ b/test/fixtures/token_instruction_data.json @@ -0,0 +1,102 @@ +[ + { + "hex": "00060b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b010d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d", + "name": "InitializeMint-some" + }, + { + "hex": "00060b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b00", + "name": "InitializeMint-none" + }, + { + "hex": "01", + "name": "InitializeAccount" + }, + { + "hex": "0202", + "name": "InitializeMultisig" + }, + { + "hex": "0340420f0000000000", + "name": "Transfer" + }, + { + "hex": "0440420f0000000000", + "name": "Approve" + }, + { + "hex": "05", + "name": "Revoke" + }, + { + "hex": "0602010d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d", + "name": "SetAuthority-some" + }, + { + "hex": "060300", + "name": "SetAuthority-none" + }, + { + "hex": "0600010d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d", + "name": "SetAuthority-mint-tokens" + }, + { + "hex": "060100", + "name": "SetAuthority-freeze" + }, + { + "hex": "0740420f0000000000", + "name": "MintTo" + }, + { + "hex": "0840420f0000000000", + "name": "Burn" + }, + { + "hex": "09", + "name": "CloseAccount" + }, + { + "hex": "0a", + "name": "FreezeAccount" + }, + { + "hex": "0b", + "name": "ThawAccount" + }, + { + "hex": "0c40420f000000000006", + "name": "TransferChecked" + }, + { + "hex": "0d40420f000000000006", + "name": "ApproveChecked" + }, + { + "hex": "0e40420f000000000006", + "name": "MintToChecked" + }, + { + "hex": "0f40420f000000000006", + "name": "BurnChecked" + }, + { + "hex": "100b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b", + "name": "InitializeAccount2" + }, + { + "hex": "11", + "name": "SyncNative" + }, + { + "hex": "120b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b", + "name": "InitializeAccount3" + }, + { + "hex": "1302", + "name": "InitializeMultisig2" + }, + { + "hex": "14060b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b010d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d0d", + "name": "InitializeMint2-some" + } +] diff --git a/test/fixtures/transactions.json b/test/fixtures/transactions.json new file mode 100644 --- /dev/null +++ b/test/fixtures/transactions.json @@ -0,0 +1,46 @@ +[ + { + "hex": "0125fa015d7db091ebdb465348df3e35e6dc3419ea6fa2192fe3ff616872fd5eb77736a5d9ad37ba02b92633ac6f0d677bc675a9cdd1b7adf43221193548dada07010001038a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c02020202020202020202020202020202020202020202020202020202020202020000000000000000000000000000000000000000000000000000000000000000090909090909090909090909090909090909090909090909090909090909090901020200010c0200000000ca9a3b00000000", + "name": "transfer-transaction" + }, + { + "hex": "8a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c", + "name": "payer-pubkey" + }, + { + "hex": "01474dd29de6780343762dc629a06cd12335951e3846d8d47ac3055284ba4df539618940da8c45f9f67dbf885010d3402b6abd678679cea57c980016f44971e704010003058a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c020202020202020202020202020202020202020202020202020202020202020200000000000000000000000000000000000000000000000000000000000000000306466fe5211732ffecadba72c39be7bc8ce5bbc5f7126b2c439b3a40000000054a535a992921064d24e87160da387c7c35b5ddbc92bb81e41fa8404105448d09090909090909090909090909090909090909090909090909090909090909090403000502400d030003000903e803000000000000020200010c0200000000ca9a3b000000000401000a68656c6c6f2d6d656d6f", + "name": "priority-transfer-transaction" + }, + { + "hex": "02496d36d26d7e55952bb5fe7b71cd4e1e7143b7f0f1e6a6e9045d4940238d652654b57b7b5532971ee57d42bfad82039490f65730d860f3ba2e791ac4bb51260179d754e17640aae8f7a5c91609e3d2e003a037d61a7830e2a8cfcb5fb3de5d3ad94e2329f65ab3a74dfb9ab774b6fbc0de806dfe74b5cd6e34d24b29d275720c020001038a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c43a72e714401762df66b68c26dfbdf2682aaec9f2474eca4613e424a0fbafd3c000000000000000000000000000000000000000000000000000000000000000009090909090909090909090909090909090909090909090909090909090909090102020001340000000040420f0000000000a5000000000000000505050505050505050505050505050505050505050505050505050505050505", + "name": "two-signer-create-transaction" + }, + { + "hex": "43a72e714401762df66b68c26dfbdf2682aaec9f2474eca4613e424a0fbafd3c", + "name": "new-account-pubkey" + }, + { + "hex": "01cf64ab743c12701893ad306fb6d6f0a0df4922b383a0a71956631553e6fb8757a67170cc3520929d322835feb10b94ef89e1b78a46f9d37a016f93268bdb8708010005088a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c4795b40be0d30fa6202595ebcb06c94d134885ba92d230a6a77ca2aa035a7c056efe5d2accdbecfa532915bef37b76201a30d63af47e53dd1879b0d9acbdd5c9000000000000000000000000000000000000000000000000000000000000000006ddf6e1d765a193d9cbe146ceeb79ac1cb485ed5f5b37913a8cf5857eff00a90b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c8c97258f4e2489f1bb3d1029148e0d830b5a1399daff1084048e7bd8dbe9f859090909090909090909090909090909090909090909090909090909090909090902070600020506030401010404010602000a0c40420f000000000006", + "name": "ata-transfer-transaction" + }, + { + "hex": "02b5ee5467feac98940c3ba1814502341943132dcdab74f260ca3ef843a16a2d08b2e394cf30c8352bfcd0590e5e18c598439bc3db10c67cded63ba12118f71b0896b9d4214c9f1c952187c3de6fa3798799540995089763aa25524f9e1f96ac34f55faf8af3a206ba2221069b0753b8697ee73a9bb230f718507a44eb3eeb3b0f020007098a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c43a72e714401762df66b68c26dfbdf2682aaec9f2474eca4613e424a0fbafd3c000000000000000000000000000000000000000000000000000000000000000006a1d8179137542a983437bdfe2a7ab2557f535c8a78722b68a49dc00000000006a1d817a502050b680791e6ce6db88e1e5b7150f61fc6790a4eb4d10000000006a7d51718c774c928566398691d5eb68b5eb8a39b4b6d5c73555b210000000006a7d517192c5c51218cc94c3d4af17f58daee089ba1fd44e3dbd98a0000000006a7d517193584d0feed9bb3431d13206be544281b57b8566cc5375ff4000000111111111111111111111111111111111111111111111111111111111111111109090909090909090909090909090909090909090909090909090909090909090302020001340000000040420f0000000000c80000000000000006a1d8179137542a983437bdfe2a7ab2557f535c8a78722b68a49dc0000000000302010674000000008a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c8a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c00f15365000000002c01000000000000121212121212121212121212121212121212121212121212121212121212121203060108050704000402000000", + "name": "stake-setup-transaction" + }, + { + "hex": "80010001028a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c0000000000000000000000000000000000000000000000000000000000000000090909090909090909090909090909090909090909090909090909090909090902010200020c0200000000ca9a3b00000000010200030c0200000020a1070000000000011f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f02000100", + "name": "v0-message" + }, + { + "hex": "01bbad9bf52a3921cda14afbb700043da146f16e8a9abc15dbcb18e3c234b8ab1af041a495878f987d0f455f1798f0a0ca1d236b9f2d98908c36508554e415600a80010001028a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c0000000000000000000000000000000000000000000000000000000000000000090909090909090909090909090909090909090909090909090909090909090902010200020c0200000000ca9a3b00000000010200030c0200000020a1070000000000011f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f1f02000100", + "name": "v0-transfer-transaction" + }, + { + "hex": "02a697cf2a40af467245d288f0907c0d26a1407b67a5bfd046aca106ae9e958bb397b7d5b96c30ecd2676ee8ee00310742a7aa45f1dc0160ed071f68f9388fae0aa8f4ce8546ac9eab1f56eff658b7359099cbfcf8d8f528411e18c04f2c0b201ffd4905d3dbd16236017bbe5f9fe80c5aec3d28dc3f72483f527003fd74ae6b050200010443a72e714401762df66b68c26dfbdf2682aaec9f2474eca4613e424a0fbafd3c8a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c02020202020202020202020202020202020202020202020202020202020202020000000000000000000000000000000000000000000000000000000000000000090909090909090909090909090909090909090909090909090909090909090901030201020c0200000000ca9a3b00000000", + "name": "sponsored-transfer-transaction" + }, + { + "hex": "01fcffc6cc51a4de7b7259f429eabff20a3a06fd71eaf9463baae5a1955eb6599778cc1576701e78db8398ce733d9c0e0a63021a4e4ce7c7de049f638bc3301002010002058a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c02020202020202020202020202020202020202020202020202020202020202022525252525252525252525252525252525252525252525252525252525252525000000000000000000000000000000000000000000000000000000000000000006a7d517192c568ee08a845f73d29788cf035c3145b21ab344d8062ea940000025bdedad9fd7d269184d58d8f80e149acc1ceb154afc3c77363d7859c1febf2e0203030204000404000000030200010c0200000000ca9a3b00000000", + "name": "nonce-transfer-transaction" + } +] diff --git a/test/fixtures/vote_instruction_data.json b/test/fixtures/vote_instruction_data.json new file mode 100644 --- /dev/null +++ b/test/fixtures/vote_instruction_data.json @@ -0,0 +1,30 @@ +[ + { + "hex": "0000000013131313131313131313131313131313131313131313131313131313131313138a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c8a88e3dd7409f195fd52db2d3cba5d72ca6709bf1d94121bf3748801b40f6f5c05", + "name": "InitializeAccount" + }, + { + "hex": "01000000141414141414141414141414141414141414141414141414141414141414141400000000", + "name": "Authorize-voter" + }, + { + "hex": "01000000141414141414141414141414141414141414141414141414141414141414141401000000", + "name": "Authorize-withdrawer" + }, + { + "hex": "0300000020a1070000000000", + "name": "Withdraw" + }, + { + "hex": "04000000", + "name": "UpdateValidatorIdentity" + }, + { + "hex": "0500000005", + "name": "UpdateCommission" + }, + { + "hex": "0700000001000000", + "name": "AuthorizeChecked" + } +]