From 19ac63e88c1926167d482c115618e839968a32ef Mon Sep 17 00:00:00 2001 From: card Date: Mon, 4 Dec 2023 17:16:31 -0500 Subject: [PATCH 1/3] replace our haskell contracts with aiken Co-authored-by: rrruko --- .../.github => .github}/workflows/tests.yml | 0 aiken/README.md => README.md | 0 aiken/aiken.lock => aiken.lock | 0 aiken/aiken.toml => aiken.toml | 0 aiken/build.sh => build.sh | 0 cabal.project | 16 - compiler/Main.hs | 222 ------ compiler/compiler.cabal | 71 -- flake.lock | 638 ---------------- flake.nix | 69 -- hie.yaml | 2 - {aiken/lib => lib}/calculation/deposit.ak | 0 {aiken/lib => lib}/calculation/donation.ak | 0 {aiken/lib => lib}/calculation/process.ak | 0 {aiken/lib => lib}/calculation/shared.ak | 0 {aiken/lib => lib}/calculation/strategy.ak | 0 {aiken/lib => lib}/calculation/swap.ak | 0 {aiken/lib => lib}/calculation/withdrawal.ak | 0 {aiken/lib => lib}/shared.ak | 0 {aiken/lib => lib}/types/order.ak | 0 {aiken/lib => lib}/types/pool.ak | 0 {aiken/lib => lib}/types/settings.ak | 0 onchain/Sundae/Compiled.hs | 331 -------- onchain/Sundae/Compiled/Factory.hs | 24 - onchain/Sundae/Compiled/Mints.hs | 36 - onchain/Sundae/Compiled/Pool.hs | 56 -- onchain/Sundae/Contracts.hs | 6 - onchain/Sundae/Contracts/Common.hs | 496 ------------ onchain/Sundae/Contracts/Factory.hs | 77 -- onchain/Sundae/Contracts/Mints.hs | 156 ---- onchain/Sundae/Contracts/Pool.hs | 398 ---------- onchain/Sundae/ShallowData.hs | 215 ------ onchain/Sundae/Utilities.hs | 486 ------------ onchain/onchain.cabal | 169 ---- onchain/test/Main.hs | 12 - onchain/test/Test/Contracts/Orphans.hs | 44 -- onchain/test/Test/Contracts/Pool.hs | 719 ------------------ .../Test/Contracts/SundaeScooperCompat.hs | 43 -- onchain/test/Test/Contracts/Utils.hs | 359 --------- onchain/test/data/factory-boot-settings.json | 10 - {aiken/validators => validators}/order.ak | 0 {aiken/validators => validators}/pool.ak | 0 .../validators => validators}/pool_stake.ak | 0 {aiken/validators => validators}/settings.ak | 0 {aiken/validators => validators}/stake.ak | 0 45 files changed, 4655 deletions(-) rename {aiken/.github => .github}/workflows/tests.yml (100%) rename aiken/README.md => README.md (100%) rename aiken/aiken.lock => aiken.lock (100%) rename aiken/aiken.toml => aiken.toml (100%) rename aiken/build.sh => build.sh (100%) delete mode 100644 cabal.project delete mode 100644 compiler/Main.hs delete mode 100644 compiler/compiler.cabal delete mode 100644 flake.lock delete mode 100644 flake.nix delete mode 100644 hie.yaml rename {aiken/lib => lib}/calculation/deposit.ak (100%) rename {aiken/lib => lib}/calculation/donation.ak (100%) rename {aiken/lib => lib}/calculation/process.ak (100%) rename {aiken/lib => lib}/calculation/shared.ak (100%) rename {aiken/lib => lib}/calculation/strategy.ak (100%) rename {aiken/lib => lib}/calculation/swap.ak (100%) rename {aiken/lib => lib}/calculation/withdrawal.ak (100%) rename {aiken/lib => lib}/shared.ak (100%) rename {aiken/lib => lib}/types/order.ak (100%) rename {aiken/lib => lib}/types/pool.ak (100%) rename {aiken/lib => lib}/types/settings.ak (100%) delete mode 100644 onchain/Sundae/Compiled.hs delete mode 100644 onchain/Sundae/Compiled/Factory.hs delete mode 100644 onchain/Sundae/Compiled/Mints.hs delete mode 100644 onchain/Sundae/Compiled/Pool.hs delete mode 100644 onchain/Sundae/Contracts.hs delete mode 100644 onchain/Sundae/Contracts/Common.hs delete mode 100644 onchain/Sundae/Contracts/Factory.hs delete mode 100644 onchain/Sundae/Contracts/Mints.hs delete mode 100644 onchain/Sundae/Contracts/Pool.hs delete mode 100644 onchain/Sundae/ShallowData.hs delete mode 100644 onchain/Sundae/Utilities.hs delete mode 100644 onchain/onchain.cabal delete mode 100644 onchain/test/Main.hs delete mode 100644 onchain/test/Test/Contracts/Orphans.hs delete mode 100644 onchain/test/Test/Contracts/Pool.hs delete mode 100644 onchain/test/Test/Contracts/SundaeScooperCompat.hs delete mode 100644 onchain/test/Test/Contracts/Utils.hs delete mode 100644 onchain/test/data/factory-boot-settings.json rename {aiken/validators => validators}/order.ak (100%) rename {aiken/validators => validators}/pool.ak (100%) rename {aiken/validators => validators}/pool_stake.ak (100%) rename {aiken/validators => validators}/settings.ak (100%) rename {aiken/validators => validators}/stake.ak (100%) diff --git a/aiken/.github/workflows/tests.yml b/.github/workflows/tests.yml similarity index 100% rename from aiken/.github/workflows/tests.yml rename to .github/workflows/tests.yml diff --git a/aiken/README.md b/README.md similarity index 100% rename from aiken/README.md rename to README.md diff --git a/aiken/aiken.lock b/aiken.lock similarity index 100% rename from aiken/aiken.lock rename to aiken.lock diff --git a/aiken/aiken.toml b/aiken.toml similarity index 100% rename from aiken/aiken.toml rename to aiken.toml diff --git a/aiken/build.sh b/build.sh similarity index 100% rename from aiken/build.sh rename to build.sh diff --git a/cabal.project b/cabal.project deleted file mode 100644 index c257f40..0000000 --- a/cabal.project +++ /dev/null @@ -1,16 +0,0 @@ -packages: - onchain/onchain.cabal - compiler/compiler.cabal - -tests: true -benchmarks: true -test-show-details: direct - -write-ghc-environment-files: never - -optimization: False - -index-state: 2023-05-15T00:00:00Z -index-state: - , hackage.haskell.org 2023-04-20T00:00:00Z - , cardano-haskell-packages 2023-05-15T00:00:00Z diff --git a/compiler/Main.hs b/compiler/Main.hs deleted file mode 100644 index 7b250db..0000000 --- a/compiler/Main.hs +++ /dev/null @@ -1,222 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} - -module Main (main) where - -import Options.Applicative qualified as O -import Data.Aeson qualified as Aeson -import Data.ByteString qualified as BS -import Data.ByteString.Char8 qualified as BS8 -import Data.ByteString.Lazy qualified as BL -import Data.ByteString.Short qualified as Short -import Data.ByteString.Base16 qualified as Hex -import Data.Map qualified as Map -import Data.Text.Encoding qualified as Text -import Data.Coerce (coerce, Coercible) -import Data.Foldable (for_) -import Data.String (fromString) -import System.Directory -import System.FilePath - -import Sundae.Contracts.Common -import Sundae.Compiled - -import PlutusLedgerApi.V2 qualified as Plutus -import PlutusLedgerApi.V1.Value (AssetClass(..), assetClass) - -data Format = Raw | Hex | Json - -data Strip = Strip | Don'tStrip - -data CompilationSettingsSource = StdIn | InFile FilePath - -data Script - = FactoryMint - | FactoryValidator - | FactoryBootCS - | PoolMint - | PoolValidator - | EscrowValidator - | SteakValidator - deriving (Enum, Bounded) - -data CompilationTarget = All | Script Script - -data Destination - = OutDirectory FilePath - | OutFile FilePath - | StdOut - -data CompileConfig = CompileConfig - { compileTarget :: CompilationTarget - , compileSettings :: CompilationSettingsSource - , compileFormat :: Format - , compileStrip :: Strip - , compileDestination :: Destination - } - -data Request - = Compile CompileConfig - -getConfig :: IO Request -getConfig = O.execParser $ O.info parser $ mconcat - [ O.fullDesc - , O.progDesc "Compile sundae contracts to disk" - , O.header "compiler - Compile SundaeSwap contracts" - ] - where - parser :: O.Parser Request - parser = O.subparser $ mconcat - [ O.command "compile" (O.info (fmap Compile pCompile) (O.progDesc "compile a single script")) - ] - pCompile :: O.Parser CompileConfig - pCompile = do - compilationTarget <- pTarget - settingsSource <- pSettings - format <- pFormat - strip <- pStrip - dest <- pDestination - pure $ CompileConfig compilationTarget settingsSource format strip dest - - pTarget :: O.Parser CompilationTarget - pTarget - = (O.flag' (Script FactoryValidator) (O.long "factory" <> O.help "compile the factory script")) - O.<|> (O.flag' (Script FactoryBootCS) (O.long "factory-boot-cs" <> O.help "compile the factory boot currency symbol")) - O.<|> (O.flag' (Script FactoryMint) (O.long "factory-mint" <> O.help "compile the factory mint script")) - O.<|> (O.flag' (Script PoolValidator) (O.long "pool" <> O.help "compile the pool script")) - O.<|> (O.flag' (Script PoolMint) (O.long "pool-mint" <> O.help "compile the pool mint script")) - O.<|> (O.flag' (Script EscrowValidator) (O.long "escrow" <> O.help "compile the escrow script")) - O.<|> (O.flag' All (O.long "all" <> O.help "compile the all scripts")) - - pSettings :: O.Parser CompilationSettingsSource - pSettings = InFile <$> (O.strOption $ mconcat - [ O.long "factory-boot-settings" - , O.metavar "FACTORY-BOOT" - , O.help "The factory boot settings to parameterize the contracts with" - ]) O.<|> pure StdIn - - pFormat = pRaw O.<|> pHex O.<|> pJson O.<|> pure Raw - pRaw = O.flag' Raw (O.long "raw" <> O.help "output the script as raw binary") - pHex = O.flag' Hex (O.long "hex" <> O.help "output the script hex-encoded") - pJson = O.flag' Json (O.long "json" <> O.help "output the script as a JSON file") - - pStrip = O.flag' Strip (O.long "strip" <> O.help "strip the cbor metadata") - O.<|> pure Don'tStrip - - pDestination :: O.Parser Destination - pDestination = OutFile <$> (O.strOption $ mconcat - [ O.long "out" - , O.metavar "DEST" - , O.help "The output file or directory to write compilation results to" - ]) O.<|> pure StdOut - -readFactoryBootSettings :: CompilationSettingsSource -> IO (Either String FactoryBootSettings) -readFactoryBootSettings StdIn = do - contents <- BL.getContents - return $ Aeson.eitherDecode contents - -makeValidatorScriptHash :: Coercible Plutus.ScriptHash a => Plutus.SerialisedScript -> a -makeValidatorScriptHash script = coerce $ Plutus.ScriptHash (Plutus.toBuiltin (hashScript script)) - -makeCurrencySymbol :: Coercible Plutus.ScriptHash a => Plutus.SerialisedScript -> a -makeCurrencySymbol = makeValidatorScriptHash - -main :: IO () -main = do - getConfig >>= \case - Compile (CompileConfig target source format strip destination) -> do - settings <- readFactoryBootSettings source >>= \case - Left e -> fail e -- todo(pi): Error messages etc. - Right s -> pure s - let - -- Hard coding these until they gets ripped out - oldPoolCurrencySymbol = OldPoolCurrencySymbol "00000000000000000000000000000000000000000000000000000000" - upgradeSettings = UpgradeSettings - { upgradeTimeLockPeriod = 0 - , upgradeAuthentication = AssetClass ("00000000000000000000000000000000000000000000000000000000", "00") - } - - -- Factory related scripts - factoryMintScript = factoryBootMintingScript settings - factoryCurrencySymbol = makeCurrencySymbol factoryMintScript :: FactoryBootCurrencySymbol - factoryValidatorScript = factoryScript factoryCurrencySymbol - - -- Pool related scripts - poolMintScript = poolMintingScript factoryCurrencySymbol - poolCurrencySymbol = makeCurrencySymbol poolMintScript :: PoolCurrencySymbol - poolValidatorScript = poolScript factoryCurrencySymbol escrowScriptHash - - steakValidatorScript = steakScript poolCurrencySymbol - steakScriptHash = makeValidatorScriptHash steakValidatorScript - - -- Escrow related scripts - escrowValidatorScript = escrowScript steakScriptHash - escrowScriptHash = makeValidatorScriptHash escrowValidatorScript - - encodeMany :: Map.Map String BS8.ByteString -> BS8.ByteString - encodeMany = case format of - Raw -> BS8.intercalate "\n" . Map.elems - Hex -> BS8.intercalate "\n" . map Hex.encode . Map.elems - Json -> BL.toStrict . Aeson.encode . Map.map (Text.decodeUtf8 . Hex.encode) - - encode :: Aeson.Key -> BS8.ByteString -> BS8.ByteString - encode name script = case format of - Raw -> script - Hex -> Hex.encode script - Json -> BL.toStrict . Aeson.encode . Aeson.object $ - [ (name, Aeson.String $ Text.decodeUtf8 $ Hex.encode script) - ] - - stripCbor :: BS8.ByteString -> BS8.ByteString - stripCbor bytes = do - let lenSize = \case - 0x58 -> Just 1 - 0x59 -> Just 2 - 0x5a -> Just 4 - 0x5b -> Just 8 - case BS.uncons bytes of - Just (hd, tl) -> - case lenSize hd of - Just n -> BS.drop n tl - Nothing -> error "stripCbor: Unexpected CBOR format" - Nothing -> error "stripCbor: Empty bytestring" - - doStrip :: Strip -> BS8.ByteString -> BS8.ByteString - doStrip s bytes = - case s of - Strip -> stripCbor bytes - Don'tStrip -> bytes - - infoForTarget :: Script -> (String, BS8.ByteString) - infoForTarget = \case - FactoryMint -> ("factory-mint", doStrip strip $ Short.fromShort factoryMintScript) - FactoryValidator -> ("factory-validator", doStrip strip $ Short.fromShort factoryValidatorScript) - FactoryBootCS -> ("factory-boot-cs", Plutus.fromBuiltin @Plutus.BuiltinByteString $ coerce factoryCurrencySymbol) - PoolMint -> ("pool-mint", doStrip strip $ Short.fromShort poolMintScript) - PoolValidator -> ("pool-validator", doStrip strip $ Short.fromShort poolValidatorScript) - EscrowValidator -> ("escrow-validator", doStrip strip $ Short.fromShort escrowValidatorScript) - SteakValidator -> ("steak-validator", doStrip strip $ Short.fromShort steakValidatorScript) - - targets :: CompilationTarget -> [(String, BS8.ByteString)] - targets = \case - Script s -> [infoForTarget s] - All -> map infoForTarget [minBound..maxBound] - - output :: [(String, BS8.ByteString)] -> Destination -> IO () - output files = \case - OutDirectory file -> do - let targetDirectory = dropFileName file - createDirectoryIfMissing True targetDirectory - for_ files \(f, scr) -> do - let path = targetDirectory ++ f - BS.writeFile path (encode (fromString f) scr) - OutFile file -> BS.writeFile file (encodeMany (Map.fromList files)) - StdOut -> BS8.putStrLn (encodeMany (Map.fromList files)) - - -- If --out was passed, but target is All, use OutDirectory instead - -- of OutFile. We can't do this in the parser itself since it's not - -- in a monad, but explicitly distinguishing OutFile and - -- OutDirectory in the destination type lets us decouple encoding - -- and output - output (targets target) $ case (target, destination) of - (All, OutFile f) -> OutDirectory f - (_, other) -> other diff --git a/compiler/compiler.cabal b/compiler/compiler.cabal deleted file mode 100644 index 65e4e64..0000000 --- a/compiler/compiler.cabal +++ /dev/null @@ -1,71 +0,0 @@ -cabal-version: 3.0 - -name: compiler -version: 0.1.0.0 -synopsis: compile sundae contracts -license-file: ../LICENSE -author: SundaeSwap Labs -maintainer: SundaeSwap Labs -build-type: Simple - -common ghc-config - ghc-options: - -Wall - default-language: Haskell2010 - default-extensions: BangPatterns - BlockArguments - ConstraintKinds - DataKinds - DeriveAnyClass - DeriveFoldable - DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable - DerivingStrategies - DerivingVia - ExplicitForAll - FunctionalDependencies - FlexibleContexts - FlexibleInstances - GADTs - GeneralizedNewtypeDeriving - ImportQualifiedPost - LambdaCase - MonoLocalBinds - MultiParamTypeClasses - NamedFieldPuns - NumericUnderscores - OverloadedStrings - PatternGuards - QuasiQuotes - RankNTypes - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TemplateHaskell - TupleSections - TypeApplications - TypeFamilies - TypeOperators - TypeSynonymInstances - ViewPatterns - -executable compiler - import: ghc-config - hs-source-dirs: . - main-is: Main.hs - build-depends: - , aeson - , base - , base16-bytestring - , bytestring - , containers - , directory - , filepath - , onchain - , optparse-applicative - , plutus-ledger-api - , text - ghc-options: - -rtsopts diff --git a/flake.lock b/flake.lock deleted file mode 100644 index d58a863..0000000 --- a/flake.lock +++ /dev/null @@ -1,638 +0,0 @@ -{ - "nodes": { - "HTTP": { - "flake": false, - "locked": { - "lastModified": 1451647621, - "narHash": "sha256-oHIyw3x0iKBexEo49YeUDV1k74ZtyYKGR2gNJXXRxts=", - "owner": "phadej", - "repo": "HTTP", - "rev": "9bc0996d412fef1787449d841277ef663ad9a915", - "type": "github" - }, - "original": { - "owner": "phadej", - "repo": "HTTP", - "type": "github" - } - }, - "cabal-32": { - "flake": false, - "locked": { - "lastModified": 1603716527, - "narHash": "sha256-X0TFfdD4KZpwl0Zr6x+PLxUt/VyKQfX7ylXHdmZIL+w=", - "owner": "haskell", - "repo": "cabal", - "rev": "48bf10787e27364730dd37a42b603cee8d6af7ee", - "type": "github" - }, - "original": { - "owner": "haskell", - "ref": "3.2", - "repo": "cabal", - "type": "github" - } - }, - "cabal-34": { - "flake": false, - "locked": { - "lastModified": 1645834128, - "narHash": "sha256-wG3d+dOt14z8+ydz4SL7pwGfe7SiimxcD/LOuPCV6xM=", - "owner": "haskell", - "repo": "cabal", - "rev": "5ff598c67f53f7c4f48e31d722ba37172230c462", - "type": "github" - }, - "original": { - "owner": "haskell", - "ref": "3.4", - "repo": "cabal", - "type": "github" - } - }, - "cabal-36": { - "flake": false, - "locked": { - "lastModified": 1669081697, - "narHash": "sha256-I5or+V7LZvMxfbYgZATU4awzkicBwwok4mVoje+sGmU=", - "owner": "haskell", - "repo": "cabal", - "rev": "8fd619e33d34924a94e691c5fea2c42f0fc7f144", - "type": "github" - }, - "original": { - "owner": "haskell", - "ref": "3.6", - "repo": "cabal", - "type": "github" - } - }, - "cardano-shell": { - "flake": false, - "locked": { - "lastModified": 1608537748, - "narHash": "sha256-PulY1GfiMgKVnBci3ex4ptk2UNYMXqGjJOxcPy2KYT4=", - "owner": "input-output-hk", - "repo": "cardano-shell", - "rev": "9392c75087cb9a3d453998f4230930dea3a95725", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "repo": "cardano-shell", - "type": "github" - } - }, - "chap": { - "flake": false, - "locked": { - "lastModified": 1684130544, - "narHash": "sha256-G9DAhJP+VUZQq4ltEsS/0AAlaXVkr45cCBrKghbbAhA=", - "owner": "input-output-hk", - "repo": "cardano-haskell-packages", - "rev": "217bbeabb2f6c836187b1da935719b05737761ae", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "ref": "repo", - "repo": "cardano-haskell-packages", - "type": "github" - } - }, - "flake-compat": { - "flake": false, - "locked": { - "lastModified": 1673956053, - "narHash": "sha256-4gtG9iQuiKITOjNQQeQIpoIB6b16fm+504Ch3sNKLd8=", - "owner": "edolstra", - "repo": "flake-compat", - "rev": "35bb57c0c8d8b62bbfd284272c928ceb64ddbde9", - "type": "github" - }, - "original": { - "owner": "edolstra", - "repo": "flake-compat", - "type": "github" - } - }, - "flake-compat_2": { - "flake": false, - "locked": { - "lastModified": 1672831974, - "narHash": "sha256-z9k3MfslLjWQfnjBtEtJZdq3H7kyi2kQtUThfTgdRk0=", - "owner": "input-output-hk", - "repo": "flake-compat", - "rev": "45f2638735f8cdc40fe302742b79f248d23eb368", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "ref": "hkm/gitlab-fix", - "repo": "flake-compat", - "type": "github" - } - }, - "flake-utils": { - "inputs": { - "systems": "systems" - }, - "locked": { - "lastModified": 1681202837, - "narHash": "sha256-H+Rh19JDwRtpVPAWp64F+rlEtxUWBAQW28eAi3SRSzg=", - "owner": "numtide", - "repo": "flake-utils", - "rev": "cfacdce06f30d2b68473a46042957675eebb3401", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "flake-utils", - "type": "github" - } - }, - "flake-utils_2": { - "locked": { - "lastModified": 1679360468, - "narHash": "sha256-LGnza3cfXF10Biw3ZTg0u9o9t7s680Ww200t5KkHTh8=", - "owner": "hamishmack", - "repo": "flake-utils", - "rev": "e1ea268ff47ad475443dbabcd54744b4e5b9d4f5", - "type": "github" - }, - "original": { - "owner": "hamishmack", - "ref": "hkm/nested-hydraJobs", - "repo": "flake-utils", - "type": "github" - } - }, - "flake-utils_3": { - "locked": { - "lastModified": 1644229661, - "narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=", - "owner": "numtide", - "repo": "flake-utils", - "rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797", - "type": "github" - }, - "original": { - "id": "flake-utils", - "type": "indirect" - } - }, - "ghc-8.6.5-iohk": { - "flake": false, - "locked": { - "lastModified": 1600920045, - "narHash": "sha256-DO6kxJz248djebZLpSzTGD6s8WRpNI9BTwUeOf5RwY8=", - "owner": "input-output-hk", - "repo": "ghc", - "rev": "95713a6ecce4551240da7c96b6176f980af75cae", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "ref": "release/8.6.5-iohk", - "repo": "ghc", - "type": "github" - } - }, - "hackage": { - "flake": false, - "locked": { - "lastModified": 1686011121, - "narHash": "sha256-X3Y62tv813/6JJ9VjT5y8s5+f2QBP6eTkY81/N9KxNg=", - "owner": "input-output-hk", - "repo": "hackage.nix", - "rev": "2d80060cbd948d851b473f4ff596d58419aebc4c", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "repo": "hackage.nix", - "type": "github" - } - }, - "haskell-nix": { - "inputs": { - "HTTP": "HTTP", - "cabal-32": "cabal-32", - "cabal-34": "cabal-34", - "cabal-36": "cabal-36", - "cardano-shell": "cardano-shell", - "flake-compat": "flake-compat_2", - "flake-utils": "flake-utils_2", - "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", - "hackage": "hackage", - "hls-1.10": "hls-1.10", - "hls-2.0": "hls-2.0", - "hpc-coveralls": "hpc-coveralls", - "hydra": "hydra", - "iserv-proxy": "iserv-proxy", - "nixpkgs": [ - "haskell-nix", - "nixpkgs-unstable" - ], - "nixpkgs-2003": "nixpkgs-2003", - "nixpkgs-2105": "nixpkgs-2105", - "nixpkgs-2111": "nixpkgs-2111", - "nixpkgs-2205": "nixpkgs-2205", - "nixpkgs-2211": "nixpkgs-2211", - "nixpkgs-2305": "nixpkgs-2305", - "nixpkgs-unstable": "nixpkgs-unstable", - "old-ghc-nix": "old-ghc-nix", - "stackage": "stackage" - }, - "locked": { - "lastModified": 1686041216, - "narHash": "sha256-RP0i9YtZbUkPtPVRz3GuBt9bwfoWCKcJ8888vocTiyg=", - "owner": "input-output-hk", - "repo": "haskell.nix", - "rev": "bc3f8b660a3b40f52139f59213652e083e6d2418", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "repo": "haskell.nix", - "type": "github" - } - }, - "hls-1.10": { - "flake": false, - "locked": { - "lastModified": 1680000865, - "narHash": "sha256-rc7iiUAcrHxwRM/s0ErEsSPxOR3u8t7DvFeWlMycWgo=", - "owner": "haskell", - "repo": "haskell-language-server", - "rev": "b08691db779f7a35ff322b71e72a12f6e3376fd9", - "type": "github" - }, - "original": { - "owner": "haskell", - "ref": "1.10.0.0", - "repo": "haskell-language-server", - "type": "github" - } - }, - "hls-2.0": { - "flake": false, - "locked": { - "lastModified": 1684398654, - "narHash": "sha256-RW44up2BIyBBYN6tZur5f9kDDR3kr0Rd+TgPbLTfwB4=", - "owner": "haskell", - "repo": "haskell-language-server", - "rev": "20c6d1e731cd9c0beef7338e2fc7a8126ba9b6fb", - "type": "github" - }, - "original": { - "owner": "haskell", - "ref": "2.0.0.0", - "repo": "haskell-language-server", - "type": "github" - } - }, - "hpc-coveralls": { - "flake": false, - "locked": { - "lastModified": 1607498076, - "narHash": "sha256-8uqsEtivphgZWYeUo5RDUhp6bO9j2vaaProQxHBltQk=", - "owner": "sevanspowell", - "repo": "hpc-coveralls", - "rev": "14df0f7d229f4cd2e79f8eabb1a740097fdfa430", - "type": "github" - }, - "original": { - "owner": "sevanspowell", - "repo": "hpc-coveralls", - "type": "github" - } - }, - "hydra": { - "inputs": { - "nix": "nix", - "nixpkgs": [ - "haskell-nix", - "hydra", - "nix", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1671755331, - "narHash": "sha256-hXsgJj0Cy0ZiCiYdW2OdBz5WmFyOMKuw4zyxKpgUKm4=", - "owner": "NixOS", - "repo": "hydra", - "rev": "f48f00ee6d5727ae3e488cbf9ce157460853fea8", - "type": "github" - }, - "original": { - "id": "hydra", - "type": "indirect" - } - }, - "iohk-nix": { - "flake": false, - "locked": { - "lastModified": 1683264256, - "narHash": "sha256-5ddG5PDwSPFdrtyxhzBZFh/10YEAHRqeD8ts6NJamVg=", - "owner": "input-output-hk", - "repo": "iohk-nix", - "rev": "18d9bc9d09ab73df58efa13a3d470b211c92f2ee", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "repo": "iohk-nix", - "type": "github" - } - }, - "iserv-proxy": { - "flake": false, - "locked": { - "lastModified": 1670983692, - "narHash": "sha256-avLo34JnI9HNyOuauK5R69usJm+GfW3MlyGlYxZhTgY=", - "ref": "hkm/remote-iserv", - "rev": "50d0abb3317ac439a4e7495b185a64af9b7b9300", - "revCount": 10, - "type": "git", - "url": "https://gitlab.haskell.org/hamishmack/iserv-proxy.git" - }, - "original": { - "ref": "hkm/remote-iserv", - "type": "git", - "url": "https://gitlab.haskell.org/hamishmack/iserv-proxy.git" - } - }, - "lowdown-src": { - "flake": false, - "locked": { - "lastModified": 1633514407, - "narHash": "sha256-Dw32tiMjdK9t3ETl5fzGrutQTzh2rufgZV4A/BbxuD4=", - "owner": "kristapsdz", - "repo": "lowdown", - "rev": "d2c2b44ff6c27b936ec27358a2653caaef8f73b8", - "type": "github" - }, - "original": { - "owner": "kristapsdz", - "repo": "lowdown", - "type": "github" - } - }, - "nix": { - "inputs": { - "lowdown-src": "lowdown-src", - "nixpkgs": "nixpkgs", - "nixpkgs-regression": "nixpkgs-regression" - }, - "locked": { - "lastModified": 1661606874, - "narHash": "sha256-9+rpYzI+SmxJn+EbYxjGv68Ucp22bdFUSy/4LkHkkDQ=", - "owner": "NixOS", - "repo": "nix", - "rev": "11e45768b34fdafdcf019ddbd337afa16127ff0f", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "2.11.0", - "repo": "nix", - "type": "github" - } - }, - "nixpkgs": { - "locked": { - "lastModified": 1657693803, - "narHash": "sha256-G++2CJ9u0E7NNTAi9n5G8TdDmGJXcIjkJ3NF8cetQB8=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "365e1b3a859281cf11b94f87231adeabbdd878a2", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixos-22.05-small", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs-2003": { - "locked": { - "lastModified": 1620055814, - "narHash": "sha256-8LEHoYSJiL901bTMVatq+rf8y7QtWuZhwwpKE2fyaRY=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "1db42b7fe3878f3f5f7a4f2dc210772fd080e205", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixpkgs-20.03-darwin", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs-2105": { - "locked": { - "lastModified": 1659914493, - "narHash": "sha256-lkA5X3VNMKirvA+SUzvEhfA7XquWLci+CGi505YFAIs=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "022caabb5f2265ad4006c1fa5b1ebe69fb0c3faf", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixpkgs-21.05-darwin", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs-2111": { - "locked": { - "lastModified": 1659446231, - "narHash": "sha256-hekabNdTdgR/iLsgce5TGWmfIDZ86qjPhxDg/8TlzhE=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "eabc38219184cc3e04a974fe31857d8e0eac098d", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixpkgs-21.11-darwin", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs-2205": { - "locked": { - "lastModified": 1682600000, - "narHash": "sha256-ha4BehR1dh8EnXSoE1m/wyyYVvHI9txjW4w5/oxsW5Y=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "50fc86b75d2744e1ab3837ef74b53f103a9b55a0", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixpkgs-22.05-darwin", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs-2211": { - "locked": { - "lastModified": 1685314633, - "narHash": "sha256-8LXBPqTQXl5ofkjpJ18JcbmLJ/lWDoMxtUwiDYv0wro=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "c8a17ce7abc03c50cd072e9e6c9b389c5f61836b", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixpkgs-22.11-darwin", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs-2305": { - "locked": { - "lastModified": 1685338297, - "narHash": "sha256-+Aq4O0Jn1W1q927ZHc3Zn6RO7bwQGmb6O8xYoGy0KrM=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "6287b47dbfabbb8bfbb9b1b53d198ad58a774de4", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixpkgs-23.05-darwin", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs-regression": { - "locked": { - "lastModified": 1643052045, - "narHash": "sha256-uGJ0VXIhWKGXxkeNnq4TvV3CIOkUJ3PAoLZ3HMzNVMw=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", - "type": "github" - }, - "original": { - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", - "type": "github" - } - }, - "nixpkgs-unstable": { - "locked": { - "lastModified": 1685347552, - "narHash": "sha256-9woSppRyUFo26yUffORTzttJ+apOt8MmCv6RxpPNTU4=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "f2f1ec390714d303cf84ba086e34e45b450dd8c4", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixpkgs-unstable", - "repo": "nixpkgs", - "type": "github" - } - }, - "old-ghc-nix": { - "flake": false, - "locked": { - "lastModified": 1631092763, - "narHash": "sha256-sIKgO+z7tj4lw3u6oBZxqIhDrzSkvpHtv0Kki+lh9Fg=", - "owner": "angerman", - "repo": "old-ghc-nix", - "rev": "af48a7a7353e418119b6dfe3cd1463a657f342b8", - "type": "github" - }, - "original": { - "owner": "angerman", - "ref": "master", - "repo": "old-ghc-nix", - "type": "github" - } - }, - "plutus-flake-utils": { - "inputs": { - "chap": "chap", - "flake-utils": "flake-utils_3", - "haskell-nix": [ - "haskell-nix" - ], - "iohk-nix": "iohk-nix", - "nixpkgs": [ - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1686181730, - "narHash": "sha256-J6mtqb9Mgkr/9Y6Tw7zluVoi6tssR7jMPYI/m0t7Css=", - "owner": "SundaeSwap-finance", - "repo": "plutus-flake-utils", - "rev": "482b35485b1983e23a00fac826f7ace50da342b9", - "type": "github" - }, - "original": { - "owner": "SundaeSwap-finance", - "ref": "rrruko/chap", - "repo": "plutus-flake-utils", - "type": "github" - } - }, - "root": { - "inputs": { - "flake-compat": "flake-compat", - "flake-utils": "flake-utils", - "haskell-nix": "haskell-nix", - "nixpkgs": [ - "haskell-nix", - "nixpkgs-unstable" - ], - "plutus-flake-utils": "plutus-flake-utils" - } - }, - "stackage": { - "flake": false, - "locked": { - "lastModified": 1685923834, - "narHash": "sha256-5oTnK+dXt1elpbLwVUYiyKroFcCMvRzEPz/PBKRtIIA=", - "owner": "input-output-hk", - "repo": "stackage.nix", - "rev": "fe1d92917a72ec690dbe61a81318931052be6179", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "repo": "stackage.nix", - "type": "github" - } - }, - "systems": { - "locked": { - "lastModified": 1681028828, - "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", - "owner": "nix-systems", - "repo": "default", - "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", - "type": "github" - }, - "original": { - "owner": "nix-systems", - "repo": "default", - "type": "github" - } - } - }, - "root": "root", - "version": 7 -} diff --git a/flake.nix b/flake.nix deleted file mode 100644 index 3a1fd87..0000000 --- a/flake.nix +++ /dev/null @@ -1,69 +0,0 @@ -{ - description = "SundaeSwap smart contracts"; - - inputs = { - nixpkgs = { - follows = "haskell-nix/nixpkgs-unstable"; - }; - - haskell-nix = { - url = "github:input-output-hk/haskell.nix"; - }; - - plutus-flake-utils = { - url = "github:SundaeSwap-finance/plutus-flake-utils/rrruko/chap"; - - # try to reduce duplicate builds - inputs = { - nixpkgs.follows = "nixpkgs"; - haskell-nix.follows = "haskell-nix"; - }; - - }; - - flake-utils = { - url = "github:numtide/flake-utils"; - }; - - flake-compat = { - url = "github:edolstra/flake-compat"; - flake = false; - }; - - }; - - outputs = - { self - , nixpkgs - , haskell-nix - , plutus-flake-utils - , flake-utils - , ... - }: - let - # can be extended if we ever have anyone on MacOS or need to cross compile. - # systems outside of this list have not been tested - supportedSystems = - [ "x86_64-linux" "x86_64-darwin" "aarch64-darwin" ]; - - projectArgs = isDocker: { - packages = [ - "onchain" - ]; - src = ./.; - compiler-nix-name = "ghc927"; - }; - in - flake-utils.lib.eachSystem supportedSystems (system: - let - plutusProject = (plutus-flake-utils.plutusProject system (projectArgs false)); - in rec { - pkgs = plutus-flake-utils.pkgs system; - inherit (plutusProject) flake project devShell; - - #devShell = plutusProject.devShell.overrideAttrs (old: { - # nativeBuildInputs = old.nativeBuildInputs ++ [ pkgs.static.haskellPackages.cabal-install pkgs.static.haskellPackages.haskell-language-server ]; - #}); - } - ); -} diff --git a/hie.yaml b/hie.yaml deleted file mode 100644 index 04cd243..0000000 --- a/hie.yaml +++ /dev/null @@ -1,2 +0,0 @@ -cradle: - cabal: diff --git a/aiken/lib/calculation/deposit.ak b/lib/calculation/deposit.ak similarity index 100% rename from aiken/lib/calculation/deposit.ak rename to lib/calculation/deposit.ak diff --git a/aiken/lib/calculation/donation.ak b/lib/calculation/donation.ak similarity index 100% rename from aiken/lib/calculation/donation.ak rename to lib/calculation/donation.ak diff --git a/aiken/lib/calculation/process.ak b/lib/calculation/process.ak similarity index 100% rename from aiken/lib/calculation/process.ak rename to lib/calculation/process.ak diff --git a/aiken/lib/calculation/shared.ak b/lib/calculation/shared.ak similarity index 100% rename from aiken/lib/calculation/shared.ak rename to lib/calculation/shared.ak diff --git a/aiken/lib/calculation/strategy.ak b/lib/calculation/strategy.ak similarity index 100% rename from aiken/lib/calculation/strategy.ak rename to lib/calculation/strategy.ak diff --git a/aiken/lib/calculation/swap.ak b/lib/calculation/swap.ak similarity index 100% rename from aiken/lib/calculation/swap.ak rename to lib/calculation/swap.ak diff --git a/aiken/lib/calculation/withdrawal.ak b/lib/calculation/withdrawal.ak similarity index 100% rename from aiken/lib/calculation/withdrawal.ak rename to lib/calculation/withdrawal.ak diff --git a/aiken/lib/shared.ak b/lib/shared.ak similarity index 100% rename from aiken/lib/shared.ak rename to lib/shared.ak diff --git a/aiken/lib/types/order.ak b/lib/types/order.ak similarity index 100% rename from aiken/lib/types/order.ak rename to lib/types/order.ak diff --git a/aiken/lib/types/pool.ak b/lib/types/pool.ak similarity index 100% rename from aiken/lib/types/pool.ak rename to lib/types/pool.ak diff --git a/aiken/lib/types/settings.ak b/lib/types/settings.ak similarity index 100% rename from aiken/lib/types/settings.ak rename to lib/types/settings.ak diff --git a/onchain/Sundae/Compiled.hs b/onchain/Sundae/Compiled.hs deleted file mode 100644 index bfc54bc..0000000 --- a/onchain/Sundae/Compiled.hs +++ /dev/null @@ -1,331 +0,0 @@ -{-# LANGUAGE IncoherentInstances #-} - --- | Wrappers for compiled scripts -module Sundae.Compiled(module X, AllScripts(..), scriptsExample, makeAllScripts, testEvalEscrowScr, hashScript) where - -import PlutusLedgerApi.V2 (SerialisedScript, TxOutRef(..), toBuiltin, OutputDatum(..)) -import PlutusLedgerApi.Common (mkDynEvaluationContext, evaluateScriptCounting, PlutusLedgerLanguage(..)) -import PlutusCore.Evaluation.Machine.ExBudgetingDefaults -import PlutusLedgerApi.Common (ProtocolVersion(..), VerboseMode(..)) -import Data.Default (def) -import Data.Either (fromRight) -import Data.Proxy (Proxy(Proxy)) -import PlutusLedgerApi.V2 qualified as Plutus -import PlutusLedgerApi.V1.Value (AssetClass(..), CurrencySymbol(..)) -import PlutusLedgerApi.V1.Value qualified as Plutus -import Data.Text -import Prelude -import GHC.Generics -import Data.Aeson -import Data.Text.Encoding qualified as Text -import Data.ByteString qualified as BS -import Data.ByteString.Lazy qualified as LBS -import Data.ByteString.Short qualified as SBS -import Data.ByteString.Base16 qualified as Base16 -import Data.Coerce (coerce) - -import Cardano.Crypto.Hash.Class (HashAlgorithm(digest)) -import Cardano.Crypto.Hash.Blake2b (Blake2b_224) - - -import Codec.Serialise (deserialise) - -import Sundae.Contracts.Common (SteakScriptHash(..), EscrowRedeemer(..), EscrowAction(..), EscrowDatum(..), EscrowAddress(..), EscrowDestination(..), FactoryBootSettings(..), ProtocolBootUTXO(..), ScooperFeeSettings(..), FactoryBootSettings, UpgradeSettings(..), FactoryBootCurrencySymbol(..), OldFactoryBootCurrencySymbol(..), TreasuryBootSettings(..), OldPoolCurrencySymbol(..), factoryToken, PoolCurrencySymbol(..), PoolScriptHash(..), ScooperFeeHolderScriptHash(..), EscrowScriptHash(..), TreasuryScriptHash(..)) - -import Sundae.Utilities (Coin(..)) - -import Sundae.Compiled.Factory as X -import Sundae.Compiled.Mints as X -import Sundae.Compiled.Pool as X - -import System.IO.Unsafe (unsafePerformIO) - -loadOrUse :: (FilePath -> IO a) -> OrPath a -> IO a -loadOrUse _ (InLine a) = return a -loadOrUse l (AsPath p) = l p - -{- -plutusScriptHash :: Serialise a => a -> Ledger.ScriptHash Crypto.StandardCrypto -plutusScriptHash script = - Ledger.hashScript @(ShelleyLedgerEra BabbageEra) $ - Alonzo.PlutusScript Alonzo.PlutusV1 (case serialiseScript script of PlutusScriptSerialised scr -> scr) --Alonzo.PlutusScript _ {- Cardano.PlutusV1 -} (case serialiseScript script of PlutusScriptSerialised scr -> scr) --} - -currencySymbolOf :: SerialisedScript -> CurrencySymbol -currencySymbolOf _ = CurrencySymbol "00000000000000000000000000000000000000000000000000000000" - -txOutRefFromStr :: Text -> Word -> TxOutRef -txOutRefFromStr txid txix = - TxOutRef - (Plutus.TxId (Plutus.toBuiltin (Text.encodeUtf8 txid))) - (fromIntegral txix) - -data AllScripts = AllScripts - { factoryBootMintScr :: SerialisedScript - , factoryBootCS :: FactoryBootCurrencySymbol - , factoryScr :: SerialisedScript - , poolMintScr :: SerialisedScript - , poolCS :: PoolCurrencySymbol - , poolScr :: SerialisedScript - , poolSH :: PoolScriptHash - , scooperFeeHolderScr :: SerialisedScript - , scooperFeeHolderSH :: ScooperFeeHolderScriptHash - , escrowScr :: SerialisedScript - , escrowSH :: EscrowScriptHash - , factoryAssetClass :: AssetClass - , steakScr :: SerialisedScript - , steakSH :: SteakScriptHash - } deriving (Generic, Show, ToJSON) - -instance ToJSON AssetClass where - toJSON (AssetClass (symbol, token)) = - object - [ "symbol" .= symbol - , "token" .= token - ] - -instance ToJSON EscrowScriptHash where -instance ToJSON ScooperFeeHolderScriptHash where -instance ToJSON PoolScriptHash where -instance ToJSON PoolCurrencySymbol where -instance ToJSON TreasuryScriptHash where -instance ToJSON FactoryBootCurrencySymbol where -instance ToJSON SteakScriptHash where - -deriving instance Generic EscrowScriptHash -deriving instance Generic ScooperFeeHolderScriptHash -deriving instance Generic PoolScriptHash -deriving instance Generic PoolCurrencySymbol -deriving instance Generic TreasuryScriptHash -deriving instance Generic FactoryBootCurrencySymbol -deriving instance Generic SteakScriptHash - -instance ToJSON SerialisedScript where - toJSON s = String $ Text.decodeUtf8 $ Base16.encode (SBS.fromShort s) - -instance ToJSON Plutus.TokenName where - toJSON (Plutus.TokenName bs) = String (Text.decodeUtf8 $ Plutus.fromBuiltin bs) - -data OrPath a = InLine !a | AsPath FilePath - deriving stock (Generic, Show) - deriving anyclass (FromJSON, ToJSON) - -type CLIBareUTXO = (Text, Word) - -data CLIAssetClass = CLIAssetClass - { currencySymbol :: Text - , tokenName :: Text - } - deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) - -fromCLIAssetClass :: CLIAssetClass -> Plutus.AssetClass -fromCLIAssetClass (CLIAssetClass policyId tokenName) = Plutus.assetClass - (either undefined (Plutus.CurrencySymbol . Plutus.toBuiltin) $ Base16.decode $ Text.encodeUtf8 policyId) - (either undefined (Plutus.TokenName . Plutus.toBuiltin) $ Base16.decode $ Text.encodeUtf8 tokenName) - -data CLIFactoryBootSettings - = CLIBrandNewFactoryBootSettings [Text] - | CLIUpgradedFactoryBootSettings (OrPath CurrencySymbol) (OrPath CurrencySymbol) - deriving (Show, Generic, ToJSON, FromJSON) - -convertFBSettings :: CLIBareUTXO -> CLIFactoryBootSettings -> FactoryBootSettings -convertFBSettings (txId, txIx) = \case - CLIBrandNewFactoryBootSettings addrs -> - BrandNewFactoryBootSettings - (ProtocolBootUTXO $ TxOutRef (Plutus.TxId . toBuiltin . fromRight (error "factory boot UTXO TXID not hex-encoded") . Base16.decode . Text.encodeUtf8 $ txId) (fromIntegral txIx)) - (readHexPubKey <$> addrs) - CLIUpgradedFactoryBootSettings oldFactoryBootSymbol _ -> - UpgradedFactoryBootSettings $ - OldFactoryBootCurrencySymbol $ - unsafePerformIO $ - loadOrUse (fmap (currencySymbolOf . deserialise) . LBS.readFile) oldFactoryBootSymbol - where - readHexPubKey k = - case Base16.decode (Text.encodeUtf8 k) of - Right bytes -> Plutus.PubKeyHash (toBuiltin bytes) - Left err -> error err - -data CLIUpgradeSettings = CLIUpgradeSettings - { cliUpgradeTimeLockSeconds :: Integer - , cliUpgradeAuthentication :: CLIAssetClass - } - deriving (Show, Generic, ToJSON, FromJSON) - -scriptsExample :: AllScripts -scriptsExample = - let - boot = ("80070000000000000000000000000000", 0) - treasBoot = ("78007000000000000000000000000000", 0) - bootSettings = CLIBrandNewFactoryBootSettings [] - upgrade = CLIUpgradeSettings 1 (CLIAssetClass "00000000000000000000000000000000000000000000000000000000" "00") - fees = ScooperFeeSettings 1 - in - makeAllScripts boot treasBoot bootSettings upgrade fees - - - -makeAllScripts :: CLIBareUTXO -> CLIBareUTXO -> CLIFactoryBootSettings -> CLIUpgradeSettings -> ScooperFeeSettings -> AllScripts -makeAllScripts bootUTXO treasBootUTXO fbSettings upgradeSettings scooperFeeSettings = - let - convertedFBSettings = convertFBSettings bootUTXO fbSettings - convertedTreasuryBootSettings = - TreasuryBootSettings $ ProtocolBootUTXO $ uncurry txOutRefFromStr treasBootUTXO - oldPoolCurrencySymbol = case fbSettings of - CLIBrandNewFactoryBootSettings {} -> OldPoolCurrencySymbol "00000000000000000000000000000000000000000000000000000000" - CLIUpgradedFactoryBootSettings _ oldSymbol -> - OldPoolCurrencySymbol $ unsafePerformIO $ loadOrUse (fmap (currencySymbolOf . deserialise) . LBS.readFile) oldSymbol - convertedUpgradeSettings = UpgradeSettings - { upgradeTimeLockPeriod = cliUpgradeTimeLockSeconds upgradeSettings * 1000 - , upgradeAuthentication = fromCLIAssetClass $ cliUpgradeAuthentication upgradeSettings - } - factoryBootMintScr = factoryBootMintingScript convertedFBSettings - - factoryBootCS = mcs factoryBootMintScr - - factoryScr = factoryScript factoryBootCS - - poolMintScr = poolMintingScript factoryBootCS - poolCS = mcs poolMintScr - poolScr = poolScript factoryBootCS escrowSH - poolSH = vsh poolScr - steakScr = steakScript poolCS - steakSH = vsh steakScr - - escrowScr = escrowScript steakSH - escrowSH = vsh escrowScr - factoryAssetClass = AssetClass (coerce factoryBootCS, factoryToken) - in AllScripts {..} - where - mcs script = coerce $ Plutus.ScriptHash (toBuiltin (hashScript script)) - vsh script = coerce $ Plutus.ScriptHash (toBuiltin (hashScript script)) - --- Reference for the implementation of script hashing: --- https://github.com/input-output-hk/cardano-ledger/blob/d421556ef91362d13963a68a94c6f9e752d67e59/eras/babbage/impl/src/Cardano/Ledger/Babbage/Scripts.hs#L35-L42 --- https://github.com/input-output-hk/cardano-ledger/blob/d421556ef91362d13963a68a94c6f9e752d67e59/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs#L449-L456 -hashScript :: SerialisedScript -> BS.ByteString -hashScript script = - let - -- Our scripts are plutus V2 - babbageV2ScriptPrefixTag = "\x02" - in - digest (Proxy @Blake2b_224) (babbageV2ScriptPrefixTag <> SBS.fromShort script) - -testEvalEscrowScr :: IO (Plutus.LogOutput, Either Plutus.EvaluationError Plutus.ExBudget) -testEvalEscrowScr = do - defCostModel <- - case defaultCostModelParams of - Just cmp -> pure cmp - Nothing -> Prelude.error "No default cost model params" - ec <- - case mkDynEvaluationContext def defCostModel of - Right ok -> pure ok - Left err -> Prelude.error (show err) - let - escrowScriptAddr = Plutus.Address - (Plutus.ScriptCredential "1111111111111111111111111111111111111111111111111111111111111111") - Nothing - poolScriptAddr = Plutus.Address - (Plutus.ScriptCredential "2222222222222222222222222222222222222222222222222222222222222222") - Nothing - myWallet = Plutus.Address - (Plutus.PubKeyCredential "3333333333333333333333333333333333333333333333333333333333333333") - Nothing - escrowDestPkh = "9999999999999999999999999999999999999999999999999999999999999999" - escrowAddress = - EscrowAddress - ( EscrowDestination - ( Plutus.Address - (Plutus.PubKeyCredential escrowDestPkh) - Nothing - ) - Nothing - ) - Nothing - coinA = AssetClass (CurrencySymbol "", Plutus.TokenName "") - coinB = AssetClass (coerce $ poolCS scriptsExample, Plutus.TokenName "p \NUL") - escrowAction = EscrowSwap (coinA, 1000000) (coinB, Nothing) - datum = EscrowDatum escrowAddress 2500000 escrowAction - redeemer = EscrowScoop - context = - Plutus.ScriptContext - { scriptContextTxInfo = - Plutus.TxInfo - { txInfoInputs = - -- the escrow - [ Plutus.TxInInfo - { txInInfoOutRef = - ( Plutus.TxOutRef - { txOutRefId = "0000000000000000000000000000000000000000000000000000000000000000" - , txOutRefIdx = 0 - } - ) - , txInInfoResolved = Plutus.TxOut - { txOutAddress = escrowScriptAddr - , txOutValue = mempty - , txOutDatum = Plutus.OutputDatumHash "" - , txOutReferenceScript = Nothing - } - } - , Plutus.TxInInfo - { Plutus.txInInfoOutRef = - ( Plutus.TxOutRef - { Plutus.txOutRefId = "0000000000000000000000000000000000000000000000000000000000000000" - , Plutus.txOutRefIdx = 1 - } - ) - , Plutus.txInInfoResolved = Plutus.TxOut - { txOutAddress = poolScriptAddr - , txOutValue = Plutus.Value $ Plutus.fromList - [ (CurrencySymbol "", Plutus.fromList [(Plutus.TokenName "", 2_000_000)]) - , (coerce $ poolCS scriptsExample, Plutus.fromList [(Plutus.TokenName "p \NUL", 1)]) - ] - , txOutDatum = NoOutputDatum - , txOutReferenceScript = Nothing - } - } - ] - , txInfoOutputs = - [ Plutus.TxOut - { txOutAddress = myWallet - , txOutValue = Plutus.Value $ Plutus.fromList - [ (CurrencySymbol "", Plutus.fromList [(Plutus.TokenName "", 2_000_000)]) - , (coerce $ poolCS scriptsExample, Plutus.fromList [(Plutus.TokenName "p \NUL", 1)]) - ] - , txOutDatum = NoOutputDatum - , txOutReferenceScript = Nothing - } - ] - , txInfoFee = mempty -- Value - , txInfoMint = mempty -- Value - , txInfoDCert = [] - , txInfoWdrl = Plutus.fromList [] - , txInfoValidRange = - Plutus.Interval - (Plutus.LowerBound Plutus.NegInf False) - (Plutus.UpperBound Plutus.PosInf False) - , txInfoSignatories = [] - , txInfoData = Plutus.fromList [] - , txInfoId = "0000000000000000000000000000000000000000000000000000000000000001" - , txInfoReferenceInputs = [] - , txInfoRedeemers = Plutus.fromList [] - } - , scriptContextPurpose = - Plutus.Spending - ( Plutus.TxOutRef - { txOutRefId = "0000000000000000000000000000000000000000000000000000000000000000" - , txOutRefIdx = 0 - } - ) - } - let out@(logOutput, result) = - evaluateScriptCounting - PlutusV2 - (ProtocolVersion 9 0) - Verbose - ec - (escrowScr scriptsExample) - [ Plutus.toData datum - , Plutus.toData redeemer - , Plutus.toData context - ] - pure out diff --git a/onchain/Sundae/Compiled/Factory.hs b/onchain/Sundae/Compiled/Factory.hs deleted file mode 100644 index 30d661c..0000000 --- a/onchain/Sundae/Compiled/Factory.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Sundae.Compiled.Factory where - -import Prelude qualified -import PlutusTx.Prelude -import qualified PlutusTx - -import PlutusLedgerApi.V2 - -import Sundae.Contracts.Common -import Sundae.Contracts.Factory -import Sundae.Utilities - -factoryScript - :: FactoryBootCurrencySymbol - -> SerialisedScript -factoryScript fbcs = - let - x = - pure $$(PlutusTx.compile [|| factoryContract ||]) - >>= flip apCode fbcs - in - case x of - Just x' -> serialiseCompiledCode x' - Nothing -> Prelude.error "Couldn't compile factory script" diff --git a/onchain/Sundae/Compiled/Mints.hs b/onchain/Sundae/Compiled/Mints.hs deleted file mode 100644 index 3652e3c..0000000 --- a/onchain/Sundae/Compiled/Mints.hs +++ /dev/null @@ -1,36 +0,0 @@ -module Sundae.Compiled.Mints where - -import Prelude qualified -import PlutusTx.Prelude -import qualified PlutusTx - -import PlutusLedgerApi.V2 - -import Sundae.Contracts.Common -import Sundae.Contracts.Mints -import Sundae.Utilities - -factoryBootMintingScript :: FactoryBootSettings -> SerialisedScript -factoryBootMintingScript fbs = - let - x = - pure $$(PlutusTx.compile [|| \fbs' -> factoryBootMintingContract fbs' ||]) - >>= flip apCode fbs - in - case x of - Just x' -> serialiseCompiledCode x' - Nothing -> Prelude.error "Couldn't compile factory boot minting script" - --- | Pool minting script -poolMintingScript - :: FactoryBootCurrencySymbol - -> SerialisedScript -poolMintingScript fbcs = - let - x = - pure $$(PlutusTx.compile [|| \fbcs' -> poolMintingContract fbcs' ||]) - >>= flip apCode fbcs - in - case x of - Just x' -> serialiseCompiledCode x' - Nothing -> Prelude.error "Couldn't compile pool minting script" diff --git a/onchain/Sundae/Compiled/Pool.hs b/onchain/Sundae/Compiled/Pool.hs deleted file mode 100644 index 125030d..0000000 --- a/onchain/Sundae/Compiled/Pool.hs +++ /dev/null @@ -1,56 +0,0 @@ -module Sundae.Compiled.Pool where - -import Prelude qualified -import PlutusTx.Prelude -import qualified PlutusTx - -import PlutusLedgerApi.V2 - -import Sundae.Contracts.Common -import Sundae.Contracts.Pool -import Sundae.Utilities - -poolScript - :: FactoryBootCurrencySymbol - -> EscrowScriptHash - -> SerialisedScript -poolScript fbcs esh = - let - x = - pure $$(PlutusTx.compile [|| \fbcs' esh' datum redeemer ctx -> - check $ poolContract fbcs' esh' - (PlutusTx.unsafeFromBuiltinData datum) - (PlutusTx.unsafeFromBuiltinData redeemer) - (PlutusTx.unsafeFromBuiltinData ctx) ||]) - >>= flip apCode fbcs - >>= flip apCode esh - in - case x of - Just x' -> serialiseCompiledCode x' - Nothing -> Prelude.error "Couldn't compile pool script" - -escrowScript - :: SteakScriptHash - -> SerialisedScript -escrowScript ssh = - let - x = - pure $$(PlutusTx.compile [|| \ssh' d r ctx -> check $ escrowContract ssh' d r ctx ||]) - >>= flip apCode ssh - in - case x of - Just x' -> serialiseCompiledCode x' - Nothing -> Prelude.error "Couldn't compile escrow script" - -steakScript - :: PoolCurrencySymbol - -> SerialisedScript -steakScript pcs = - let - x = - pure $$(PlutusTx.compile [|| \pcs' r ctx -> check $ steakContract pcs' r ctx ||]) - >>= flip apCode pcs - in - case x of - Just x' -> serialiseCompiledCode x' - Nothing -> Prelude.error "Couldn't compile steak script" diff --git a/onchain/Sundae/Contracts.hs b/onchain/Sundae/Contracts.hs deleted file mode 100644 index a9c511d..0000000 --- a/onchain/Sundae/Contracts.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Sundae.Contracts(module X) where - -import Sundae.Contracts.Common as X -import Sundae.Contracts.Factory as X -import Sundae.Contracts.Mints as X -import Sundae.Contracts.Pool as X diff --git a/onchain/Sundae/Contracts/Common.hs b/onchain/Sundae/Contracts/Common.hs deleted file mode 100644 index 40d8305..0000000 --- a/onchain/Sundae/Contracts/Common.hs +++ /dev/null @@ -1,496 +0,0 @@ -{-# OPTIONS_GHC -fno-unbox-small-strict-fields #-} - -module Sundae.Contracts.Common where - -import qualified Prelude -import PlutusTx.Prelude -import PlutusTx.Sqrt -import Data.Aeson qualified as Aeson -import Data.Aeson (FromJSON(..), ToJSON(..), withScientific, withObject, (.:), (.=)) -import Data.ByteString.Base16 qualified as Base16 -import Data.Text.Encoding qualified as Text - -import PlutusLedgerApi.V1.Value -import PlutusLedgerApi.V2 - -import qualified PlutusTx -import qualified PlutusTx.AssocMap as Map -import PlutusTx.Ratio - -import GHC.Generics -import Control.DeepSeq -import Sundae.Utilities - -import Control.Lens (makeLenses) - --- | Factory script controls creation of pools -data Factory - --- | Script that holds all live pools -data Pool - --- | Script that holds all escrows -data Escrow - -instance FromJSON TxOutRef where - parseJSON = withObject "TxOutRef" $ \o -> do - txid <- o .: "txid" - txix <- o .: "txix" - Prelude.pure $ TxOutRef - { txOutRefId = TxId txid - , txOutRefIdx = txix - } - -instance ToJSON TxOutRef where - toJSON (TxOutRef { txOutRefId = TxId txid, txOutRefIdx = txix }) = - Aeson.object - [ "txid" .= txid - , "txix" .= txix - ] - --- | A single UTXO that uniquely identifies / parameterizes the entire protocol --- | This ensures that anyone who runs our scripts with a different UTXO --- | ends up with different policy IDs / script hashes, and is a fundamentally different protocol -newtype ProtocolBootUTXO = ProtocolBootUTXO - { unProtocolBootUTXO :: TxOutRef - } - deriving stock (Generic, Prelude.Show) - deriving newtype (ToJSON) - -instance FromJSON ProtocolBootUTXO where - parseJSON v = Prelude.fmap ProtocolBootUTXO $ parseJSON v - --- | Used to make the treasury token an NFT. -newtype TreasuryBootSettings = TreasuryBootSettings - { treasury'protocolBootUTXO :: ProtocolBootUTXO - } - --deriving newtype (FromJSON, ToJSON) - -instance FromJSON PubKeyHash where - parseJSON = Aeson.withText "PubKeyHash" $ \s -> do - dec <- case Base16.decode (Text.encodeUtf8 s) of - Right ok -> Prelude.pure ok - Left err -> Prelude.fail err - Prelude.pure (PubKeyHash (toBuiltin dec)) - -instance ToJSON PubKeyHash where - toJSON (PubKeyHash pkh) = - let - bytes = fromBuiltin pkh - hex = Base16.encode bytes - text = Text.decodeUtf8 hex - in - Aeson.String text - -data FactoryBootSettings - = BrandNewFactoryBootSettings - { factory'protocolBootUTXO :: ProtocolBootUTXO - , initialLegalScoopers :: [PubKeyHash] - } - | UpgradedFactoryBootSettings - { oldFactoryBootCurrencySymbol :: OldFactoryBootCurrencySymbol - } - deriving stock (Generic, Prelude.Show) - deriving anyclass (ToJSON) - -instance FromJSON FactoryBootSettings where - parseJSON = withObject "FactoryBootSettings" $ \obj -> do - utxo <- obj .: "protocolBootUTXO" - scoopers <- obj .: "scoopers" - return $ BrandNewFactoryBootSettings utxo scoopers - -data UpgradeSettings = UpgradeSettings - { upgradeTimeLockPeriod :: Integer - , upgradeAuthentication :: AssetClass - } - deriving stock (Generic, Prelude.Show) - --deriving anyclass (FromJSON, ToJSON) - --- | The destination for the results of an escrowed operation. --- Could be a user address, but could also be a script address + datum --- for composing with other protocols. -data EscrowDestination = EscrowDestination !Address !(Maybe DatumHash) - deriving stock (Prelude.Show, Prelude.Eq, Prelude.Ord, Generic) - --deriving anyclass (NFData, ToJSON, FromJSON) - -instance Eq EscrowDestination where - {-# inlinable (==) #-} - (==) (EscrowDestination addr1 dh1) (EscrowDestination addr2 dh2) = - addr1 == addr2 && dh1 == dh2 - --- | An escrow's address information. --- The first field is the destination for the results of the escrowed operation. --- The second field can also supply auxiliary PubKeyHash which can be used to authenticate cancelling this order. -data EscrowAddress = EscrowAddress !EscrowDestination !(Maybe PubKeyHash) - deriving stock (Prelude.Show, Prelude.Eq, Prelude.Ord, Generic) - --deriving anyclass (NFData, ToJSON, FromJSON) - -instance Eq EscrowAddress where - {-# inlinable (==) #-} - (==) (EscrowAddress dest1 pkh1) (EscrowAddress dest2 pkh2) = - dest1 == dest2 && pkh1 == pkh2 - -{-# inlinable escrowPubKeyHashes #-} -escrowPubKeyHashes :: EscrowAddress -> [PubKeyHash] -escrowPubKeyHashes (EscrowAddress (EscrowDestination addr _) mPubKey) = - mapMaybe id [toPubKeyHash addr, mPubKey] - where - toPubKeyHash (Address cred stakingCred) = - case cred of - PubKeyCredential pkh -> Just pkh - _ -> Nothing - -{-# inlinable fromEscrowAddress #-} -fromEscrowAddress :: EscrowAddress -> EscrowDestination -fromEscrowAddress (EscrowAddress dest _) = dest - -newtype SwapFees = SwapFees Rational - deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData, Eq, NFData) - deriving (Prelude.Show) - -instance FromJSON SwapFees where - parseJSON = withScientific "SwapFees" $ \sci -> return (SwapFees (fromGHC (Prelude.toRational sci))) - -instance ToJSON SwapFees where - toJSON (SwapFees r) = - toJSON (Prelude.fromRational (toGHC r) :: Prelude.Double) - -instance ToJSON POSIXTime where -instance FromJSON POSIXTime where -instance ToJSON CurrencySymbol where -instance FromJSON CurrencySymbol where -instance ToJSON ScriptHash where -instance FromJSON ScriptHash where - -data FactoryDatum = FactoryDatum - { poolScriptHash :: ScriptHash - , poolCurrencySymbol :: CurrencySymbol - , scooperSet :: ![PubKeyHash] - -- permissible staking credentials for pool - , poolStakingCredSet :: ![StakingCredential] - } - deriving stock (Generic, Prelude.Show) - --deriving anyclass (NFData, ToJSON, FromJSON) - -instance Eq FactoryDatum where - {-# inlinable (==) #-} - FactoryDatum poolSH' poolCS' scooperSet' poolStakingCredSet' == - FactoryDatum poolSH'' poolCS'' scooperSet'' poolStakingCredSet'' = - poolSH' == poolSH'' && - poolCS' == poolCS'' && - scooperSet' == scooperSet'' && - poolStakingCredSet' == poolStakingCredSet'' - --- | Action on factory script -data FactoryRedeemer - = FactorySetPoolScriptInfo - --deriving (Generic, ToJSON, FromJSON) - -instance Eq FactoryRedeemer where - {-# inlinable (==) #-} - _ == _ = True - -data FactoryBootMintRedeemer - = MakeFactory - | MakeScooperToken - -data PoolMintRedeemer - = MintLP BuiltinByteString -- Mint LP for the given pool ident - | CreatePool AssetClass AssetClass - -data ScooperFeeSettings - = ScooperFeeSettings - { scooperRewardRedeemDelayWeeks :: Integer - } --deriving (Generic, NFData, Prelude.Show, ToJSON, FromJSON) - -data ScooperFeeDatum - = ScooperFeeDatum - { scooperLicensee :: !PubKeyHash - } --deriving (Generic, NFData, Prelude.Show, ToJSON, FromJSON) - -data ScooperFeeRedeemer - = ScooperCollectScooperFees - --- | Pool internal state -data PoolDatum - = PoolDatum - { _pool'coins :: !(AB AssetClass) -- ^ pair of coins on which pool operates - , _pool'poolIdent :: !BuiltinByteString -- ^ unique identifier of the pool. - , _pool'circulatingLP :: !Integer -- ^ amount of minted liquidity - , _pool'swapFees :: !SwapFees -- ^ this pool's trading fee. - , _pool'marketOpenTime :: !POSIXTime -- ^ time to enable swaps on this pool - , _pool'rewards :: !Integer -- ^ ADA reserved for scooper rewards - } deriving (Generic, NFData, Prelude.Show) - -instance Eq PoolDatum where - {-# inlinable (==) #-} - PoolDatum coinPair ident issuedLiquidity swapFees marketOpenTime rewards == - PoolDatum coinPair' ident' issuedLiquidity' swapFees' marketOpenTime' rewards' = - coinPair == coinPair' && ident == ident' && issuedLiquidity == issuedLiquidity' && swapFees == swapFees' && marketOpenTime == marketOpenTime' && rewards == rewards' - -data PoolRedeemer - = PoolScoop !PubKeyHash [Integer] -- OPTIMIZATION: PKH here is candidate for removal - --- | The escrow datum specified which pool it's intended for, what the return --- address is for any results of the escrowed operation, and the amount of --- lovelace intended to be paid to the scooper. -data EscrowDatum = EscrowDatum - { _escrow'address :: EscrowAddress - , _escrow'scoopFee :: Integer - , _escrow'action :: EscrowAction - } - deriving stock (Prelude.Show, Prelude.Eq, Prelude.Ord, Generic) - --deriving anyclass (NFData, ToJSON, FromJSON) - -instance Eq EscrowDatum where - EscrowDatum ret fee act == EscrowDatum ret' fee' act' = - ret == ret' && fee == fee' && act == act' - --- | Deposits take the form of single-asset and mixed-asset deposits. -data Deposit = DepositSingle Coin Integer | DepositMixed (AB Integer) - deriving stock (Prelude.Show, Prelude.Eq, Prelude.Ord, Generic) - --deriving anyclass (NFData, ToJSON, FromJSON) - -instance Eq Deposit where - {-# inlinable (==) #-} - DepositSingle coin n == DepositSingle coin' n' = coin == coin' && n == n' - DepositMixed ab == DepositMixed ab' = ab == ab' - _ == _ = False - --- | Escrow actions -data EscrowAction - -- | Swap to address given amount of tokens (Integer) of asset (AssetClass), - -- expecting to get at least some amount (Integer) in return. - = EscrowSwap (AssetClass, Integer) (AssetClass, Maybe Integer) - -- | Withdraw some amount of liquidity, by burning liquidity tracking tokens. - | EscrowWithdraw BuiltinByteString Integer - -- | Make a deposit, in exchange for newly-minted liquidity tracking tokens. - | EscrowDeposit BuiltinByteString Deposit - deriving stock (Prelude.Show, Prelude.Eq, Prelude.Ord, Generic) - --deriving anyclass (NFData, ToJSON, FromJSON) - -instance Eq EscrowAction where - {-# inlinable (==) #-} - EscrowSwap (coinGive, gives) (coinTake, minTakes) == EscrowSwap (coinGive', gives') (coinTake', minTakes') = - coinGive == coinGive' && gives == gives' && coinTake == coinTake' && minTakes == minTakes' - EscrowWithdraw poolId givesLiq == EscrowWithdraw poolId' givesLiq' = - poolId == poolId' && givesLiq == givesLiq' - EscrowDeposit poolId dep == EscrowDeposit poolId' dep' = - poolId == poolId' && dep == dep' - _ == _ = - False - --- | Escrow redeemer -data EscrowRedeemer - -- ^ scooper collects escrow actions to execute them on pool - = EscrowScoop - -- ^ user withdraws their escrow - | EscrowCancel - -newtype FactoryScriptHash = FactoryScriptHash ScriptHash - deriving stock Prelude.Show -newtype TreasuryScriptHash = TreasuryScriptHash ScriptHash - deriving stock Prelude.Show -newtype SteakScriptHash = SteakScriptHash ScriptHash - deriving stock Prelude.Show - -newtype FactoryBootCurrencySymbol = FactoryBootCurrencySymbol CurrencySymbol - deriving stock Prelude.Show -newtype OldFactoryBootCurrencySymbol = OldFactoryBootCurrencySymbol CurrencySymbol - deriving stock Prelude.Show - deriving newtype (FromJSON, ToJSON) -newtype TreasuryBootCurrencySymbol = TreasuryBootCurrencySymbol CurrencySymbol - deriving stock Prelude.Show -newtype OldPoolCurrencySymbol = OldPoolCurrencySymbol CurrencySymbol - deriving stock Prelude.Show -newtype PoolCurrencySymbol = PoolCurrencySymbol CurrencySymbol - deriving stock Prelude.Show - -newtype ScooperFeeHolderScriptHash = ScooperFeeHolderScriptHash ScriptHash - deriving stock Prelude.Show -newtype PoolScriptHash = PoolScriptHash ScriptHash - deriving stock Prelude.Show -newtype EscrowScriptHash = EscrowScriptHash ScriptHash - deriving stock Prelude.Show - -factoryToken :: TokenName -factoryToken = TokenName "factory" - --- Asset name can be 28 bytes; 19 bytes reserved for the week number; --- That gives us ~5.3e45 weeks to work with. We should be good :) -{-# inlinable computeScooperTokenName #-} -computeScooperTokenName :: Ident -> TokenName -computeScooperTokenName (Ident ident) = TokenName $ "scooper " <> ident - -{-# inlinable computeLiquidityTokenName #-} -computeLiquidityTokenName :: BuiltinByteString -> TokenName -computeLiquidityTokenName poolIdent = TokenName $ "l" <> poolIdent - -{-# inlinable computePoolTokenName #-} -computePoolTokenName :: BuiltinByteString -> TokenName -computePoolTokenName poolIdent = TokenName $ "p" <> poolIdent - -PlutusTx.makeLift ''OldFactoryBootCurrencySymbol -PlutusTx.makeLift ''ProtocolBootUTXO -PlutusTx.makeLift ''FactoryBootSettings -PlutusTx.makeLift ''TreasuryBootSettings -PlutusTx.makeLift ''UpgradeSettings -PlutusTx.makeLift ''ScooperFeeSettings -PlutusTx.makeIsDataIndexed ''FactoryBootMintRedeemer [('MakeFactory, 0), ('MakeScooperToken, 1)] -PlutusTx.makeIsDataIndexed ''FactoryDatum [('FactoryDatum, 0)] -PlutusTx.makeIsDataIndexed ''FactoryRedeemer [('FactorySetPoolScriptInfo, 0)] -PlutusTx.makeIsDataIndexed ''ScooperFeeDatum [('ScooperFeeDatum, 0)] -PlutusTx.makeIsDataIndexed ''ScooperFeeRedeemer [('ScooperCollectScooperFees, 0)] -PlutusTx.makeIsDataIndexed ''PoolRedeemer [('PoolScoop, 0)] -PlutusTx.makeIsDataIndexed ''PoolDatum [('PoolDatum, 0)] -PlutusTx.makeIsDataIndexed ''Deposit [('DepositSingle, 0), ('DepositMixed, 1)] -PlutusTx.makeIsDataIndexed ''EscrowAction [('EscrowSwap, 0), ('EscrowWithdraw, 1), ('EscrowDeposit, 2)] -PlutusTx.makeIsDataIndexed ''EscrowDestination [('EscrowDestination, 0)] -PlutusTx.makeIsDataIndexed ''EscrowAddress [('EscrowAddress, 0)] -PlutusTx.makeIsDataIndexed ''EscrowDatum [('EscrowDatum, 0)] -PlutusTx.makeIsDataIndexed ''EscrowRedeemer [('EscrowScoop, 0), ('EscrowCancel, 1)] -PlutusTx.makeIsDataIndexed ''PoolMintRedeemer [('MintLP, 0), ('CreatePool, 1)] -PlutusTx.makeLift ''FactoryBootCurrencySymbol -PlutusTx.makeLift ''TreasuryBootCurrencySymbol -PlutusTx.makeLift ''FactoryScriptHash -PlutusTx.makeLift ''PoolScriptHash -PlutusTx.makeLift ''TreasuryScriptHash -PlutusTx.makeLift ''ScooperFeeHolderScriptHash -PlutusTx.makeLift ''PoolCurrencySymbol -PlutusTx.makeLift ''OldPoolCurrencySymbol -PlutusTx.makeLift ''EscrowScriptHash -PlutusTx.makeLift ''SteakScriptHash - ---instance Scripts.ValidatorTypes Factory where --- type instance DatumType Factory = FactoryDatum --- type instance RedeemerType Factory = FactoryRedeemer --- ---instance Scripts.ValidatorTypes Escrow where --- type instance DatumType Escrow = EscrowDatum --- type instance RedeemerType Escrow = EscrowRedeemer --- ---instance Scripts.ValidatorTypes Pool where --- type instance DatumType Pool = PoolDatum --- type instance RedeemerType Pool = PoolRedeemer --- - --- Here, instead of utilities, to avoid dependency cycle -{-# inlinable mergeListByKey #-} -mergeListByKey :: [(EscrowDestination, ABL Integer)] -> [(EscrowDestination, ABL Integer, Integer)] -mergeListByKey cs = go cs [] - where - -- Fold over the constraints, accumulating a list of merged constraints - go ((r,v):xs) acc = - -- If we've already seen this before, add together the values and the order counts - case valueInList r acc Nothing [] of - Just ((v', c), acc') -> - let !v'' = v + v' - !c' = c + 1 - in go xs ((r, v'', c') : acc') - Nothing -> go xs ((r,v,1) : acc) - go [] acc = acc - - valueInList _ [] Nothing _ = Nothing - valueInList _ [] (Just (v, c)) acc = Just ((v, c), acc) - valueInList r (x@(r', v', c') : tl) res@Nothing acc - | r == r' = valueInList r tl (Just (v', c')) acc - | otherwise = valueInList r tl res (x : acc) - valueInList r (x : tl) res@(Just _) acc = valueInList r tl res (x : acc) - --- Every UTXO in cardano must come with a minimum amount of ADA to prevent dust attacks; --- We've been calling this the "rider". --- Technically this is dependent on the number of bytes in the UTXO, but to avoid complications --- we just fix a specific rider size. Since most of our protocol is passing NFTs through, this --- usually isn't an additional requirement for most operations, or it comes back to the user in --- the long run. -{-# inlinable riderAmount #-} -riderAmount :: Integer -riderAmount = 2_000_000 - --- If multiple orders for the same destination are in the same order, we need to --- subtract the deposit for each, to ensure that ada isn't getting skimmed off the top -{-# inlinable sansRider' #-} -sansRider' :: Integer -> Value -> Value -sansRider' c v = - let - !lovelace = valueOf v adaSymbol adaToken - !finalRider = riderAmount * c - in - if lovelace < finalRider - then die "not enough Ada to cover the rider" - else - let v_l = removeSymbol adaSymbol (Map.toList $ getValue v) [] in - if lovelace - finalRider /= 0 then - Value $ Map.fromList ((adaSymbol, Map.singleton adaToken (lovelace - finalRider)) : v_l) - else - Value $ Map.fromList v_l - -{-# inlinable removeSymbol #-} -removeSymbol _ [] acc = acc -removeSymbol sym (x@(cs, _) : tl) acc - | sym == cs = removeSymbol sym tl acc - | otherwise = removeSymbol sym tl (x : acc) - --- In the pool contract, we subtract off the riders so as not to affect the price calculation -{-# inlinable sansRider #-} -sansRider :: Value -> Value -sansRider v = sansRider' 1 v - -{-# inlinable sansAda #-} -sansAda :: Integer -> Value -> Value -sansAda extra v = - let - !lovelace = valueOf v adaSymbol adaToken - in - if lovelace < extra - then die "not enough ada" - else - let v_l = removeSymbol adaSymbol (Map.toList $ getValue v) [] in - if lovelace - extra /= 0 then - Value $ Map.fromList ((adaSymbol, Map.singleton adaToken (lovelace - extra)) : v_l) - else - Value $ Map.fromList v_l - --- Valid fees for the protocol --- [0.05%, 0.3%, 1%] -{-# inlinable legalSwapFees #-} -legalSwapFees :: [SwapFees] -legalSwapFees = SwapFees <$> [1 % 2000, 3 % 1000, 1 % 100] - --- The largest valid range for most time-sensitive operations --- We don't get access to an exact time (since the transaction could get accepted in many blocks) --- so we need to bound the valid range, to ensure we have an approximate idea of the time of the transaction --- 1000 * 60 * 60 = 3_600_000 -{-# inlinable hourMillis #-} -hourMillis :: Integer -hourMillis = 3_600_000 - --- In order to allow governance to revoke access to a list of scoopers, we expire the tokens on regular intervals -{-# inlinable scooperLicenseExpiryDelayWeeks #-} -scooperLicenseExpiryDelayWeeks :: Integer -scooperLicenseExpiryDelayWeeks = 1 - -{-# inlinable scaleInteger #-} -scaleInteger :: Rational -> Integer -> Integer -scaleInteger r n = truncate $ r * fromInteger n - -{-# inlinable computeInitialLiquidityTokens #-} -computeInitialLiquidityTokens :: Integer -> Integer -> Integer -computeInitialLiquidityTokens amtA amtB = - case rsqrt (fromInteger $ amtA * amtB) of - Exactly n -> n - Approximately n -> n - Imaginary -> error () - -{-# inlinable toPoolNft #-} -toPoolNft :: CurrencySymbol -> BuiltinByteString -> AssetClass -toPoolNft cs poolIdent = assetClass cs (computePoolTokenName poolIdent) - -makeLenses ''PoolDatum -makeLenses ''EscrowDatum - -{-# inlinable isFactory #-} -isFactory :: CurrencySymbol -> TxOut -> Bool -isFactory fbcs o = assetClassValueOf (txOutValue o) factoryNft == 1 - where - factoryNft = assetClass fbcs factoryToken diff --git a/onchain/Sundae/Contracts/Factory.hs b/onchain/Sundae/Contracts/Factory.hs deleted file mode 100644 index 3d09b0b..0000000 --- a/onchain/Sundae/Contracts/Factory.hs +++ /dev/null @@ -1,77 +0,0 @@ -module Sundae.Contracts.Factory where - -import PlutusTx.Prelude - -import PlutusLedgerApi.V2 -import PlutusLedgerApi.V1.Value - -import Sundae.Contracts.Common -import Sundae.Utilities - --- Factory Contract --- Locks the "Factory NFT" and brokers protocol operations relating to pools. --- Parameterized by: --- Factory Settings, including time-lock period for upgrades --- FactoryBootCurrencySymbol, identifying the NFT --- ProposalScriptHash, the script which will broker a protocol upgrade --- PoolScriptHash, the contract governing each liquidity pool --- PoolCurrencySymbol, the NFT identifying each pool --- Uses Datum: --- nextPoolIdent, proposalState, scooperIdent, and a list of valid scoopers --- Allows (via Redeemer): --- - Creating new pools --- - Starting a protocol upgrade --- - Finalizing a protocol upgrade --- - Issuing scooper licenses --- - Updating list of valid scoopers --- Details: --- The factory contract acts as a supply of unique names, which pools are --- identified by, and validates the initial data of pools. Those uniques are --- also included in the token names of tokens that have to be associated with --- particular pools, like liquidity tracking tokens and pool NFTs. --- --- It also dispenses scooper license tokens, which are required to do scoops, --- and maintains a list of public keys that belong to legal scoopers. That list can be --- updated through a governance action. --- --- The factory can be "killed" by a full governance upgrade, after which its --- NFT is passed to the "dead factory contract". --- -{-# inlinable factoryContract #-} -factoryContract - :: FactoryBootCurrencySymbol - -> BuiltinData -- FactoryDatum - -> BuiltinData -- FactoryRedeemer - -> BuiltinData -- ScriptContext - -> Bool -factoryContract - (FactoryBootCurrencySymbol fbcs) - (unsafeFromBuiltinData -> (datum :: FactoryDatum)) - _ - (unsafeFromBuiltinData -> ctx) = - debug "factory token not spent back" - (hasFactoryLimited fbcs (txOutValue ownOutput)) && - debug "factory output not equal to input factory" - (ownInputValue == txOutValue ownOutput) && - debug "datum altered" - (if poolScriptHash datum == ScriptHash mempty && poolCurrencySymbol datum == CurrencySymbol mempty - then True -- OK to update things if the pool info hasn't been set yet - else rawDatumOf txInfo ownOutput == fromBuiltinData (toBuiltinData datum)) && - debug "minting tokens" - (txInfoMint == mempty) - where - txInfo@TxInfo{..} = scriptContextTxInfo ctx - ownOutput = uniqueElement' continuingOutputs - !continuingOutputs = getContinuingOutputs ctx - !ownInput = scriptInput ctx - ownInputValue = txOutValue ownInput - -{-# inlinable toFactoryNft #-} -toFactoryNft :: CurrencySymbol -> AssetClass -toFactoryNft cs = assetClass cs factoryToken - -{-# inlinable hasFactoryLimited #-} --- | Factory value should contain factory NFt and no more than 2 items in the value: --- Ada, NFT -hasFactoryLimited :: CurrencySymbol -> Value -> Bool -hasFactoryLimited cs val = hasLimitedNft 2 (toFactoryNft cs) val diff --git a/onchain/Sundae/Contracts/Mints.hs b/onchain/Sundae/Contracts/Mints.hs deleted file mode 100644 index 6217a1f..0000000 --- a/onchain/Sundae/Contracts/Mints.hs +++ /dev/null @@ -1,156 +0,0 @@ -module Sundae.Contracts.Mints where - -import PlutusTx.Prelude -import PlutusTx.Builtins - -import qualified PlutusTx.AssocMap as Map - -import Sundae.Contracts.Common -import Sundae.Utilities - -import PlutusLedgerApi.V2 - -ownCurrencySymbol :: ScriptContext -> CurrencySymbol -ownCurrencySymbol (ScriptContext _ purpose) = - case purpose of - Minting cs -> cs - Spending _ -> die "ownCurrencySymbol" - --- Factory Boot Minting Contract --- Controls creation of tokens used for the factory script --- Parameterized by: --- Factory Boot Settings, including the protocol boot UTXO and the initial set of legal scoopers --- Allows (via Redeemer): --- - Starting the protocol from scratch --- - Initializing the new "post-upgrade" factory token --- - Minting scooper license tokens -{-# inlinable factoryBootMintingContract #-} -factoryBootMintingContract :: FactoryBootSettings -> BuiltinData -> BuiltinData -> Bool -factoryBootMintingContract fbs (unsafeFromBuiltinData -> redeemer) (unsafeFromBuiltinData -> ctx) = case redeemer of - MakeFactory -> - debug "not minting a factory token" - (Map.lookup ocs (getValue txInfoMint) == Just (Map.singleton factoryToken 1)) && - case fbs of - BrandNewFactoryBootSettings{..} -> - debug "not spending protocol boot UTXO" - (atLeastOne (\input -> txInInfoOutRef input == unProtocolBootUTXO factory'protocolBootUTXO) txInfoInputs) - -- Because we control this transaction, some non-security-critical checks are omitted: - -- Not checking Factory datum - -- Not checking that it's spent into the factory script - UpgradedFactoryBootSettings (OldFactoryBootCurrencySymbol oldFbcs) -> - debug "not spending the old factory token" -- TODO: Think about redeemer of factory script - (atLeastOne (\input -> valueContains (txOutValue $ txInInfoResolved input) oldFbcs factoryToken) txInfoInputs) - MakeScooperToken -> - debug "only scooper tokens minted" - (onlyHas txInfoMint ocs (computeScooperTokenName (intToIdent $ getWeek week)) (\n -> if n > 0 then checkLicenseIssuable else True)) - where - checkLicenseIssuable = - debug "not spending factory token" - (atLeastOne (\input -> valueContains (txOutValue (txInInfoResolved input)) ocs factoryToken) txInfoInputs) - UpperBound (Finite latest) _ = ivTo txInfoValidRange - week = toWeek latest - ocs = ownCurrencySymbol ctx - TxInfo{..} = scriptContextTxInfo ctx - --- Pool minting contract --- Controls creation of liquidity pools and liquidity tracking tokens --- Parameterized by: --- FactoryBootCurrencySymbol, which points to the Factory NFT --- OldPoolCurrencySymbol, the old pool, if we've gone through an upgrade --- Allows: --- - Creation of liquidity pool NFTs and liquidity tracking tokens, provided the factory is cooperating --- Details: --- Effectively, this script has the factory token, and pool tokens, as --- permission slips for arbitrary minting. That means we have to be careful --- in the scripts that hold those to check that we don't mint anything unexpected. -{-# inlinable poolMintingContract #-} -poolMintingContract - :: FactoryBootCurrencySymbol - -> BuiltinData -- PoolMintRedeemer - -> BuiltinData -- ScriptContext - -> () -poolMintingContract - (FactoryBootCurrencySymbol fbcs) - (unsafeFromBuiltinData -> redeemer) - rawCtx = check $ - case redeemer of - MintLP poolIdent -> - let - poolTokenName = computePoolTokenName poolIdent - allowsToSpend !v = - if valueContains v ocs poolTokenName then - True - else - valueContains v fbcs factoryToken - in - -- The below is sufficient condition, *provided that* - -- Each of the following script/redeemer combinations check that they are minting the correct token - -- factoryContract / CreatePool -> Only Mint Pool Tokens + Liquidity Tokens (Checked) - -- factoryContract / ISL -> Only Mint or Burn Scooper License Tokens (Checked) - -- factoryContract / MakeProposal -> None (Checked) - -- factoryContract / UpgradeFactory -> Only Mint New Factory Tokens (Checked) - -- deadFactoryContract / _ -> Only Mint New Pool + New Liquidity (Checked) - -- poolContract / Scoop -> Only Mint or Burn Liquidity Tokens (Checked) - -- poolContract / Upgrade -> Must have dead factory first (Checked) - -- deadPoolContract / _ -> Only Burn Liquidity Tokens (Checked) - debug "can only mint: lp tokens with the pool token, an upgraded pool with the old pool, or a pool token with the factory token" - (atLeastOne (allowsToSpend.txOutValue.txInInfoResolved) ins) - CreatePool coinA coinB -> - let - getIdent (Ident i) = i - !firstInput = txInInfoOutRef (ins !! 0) - -- A pool ident is 31 bytes in order to make it fit in the LP / pool - -- NFT token names with an extra byte for labeling. So we truncate the - -- blake2 hash. - !newPoolIdent = dropByteString 1 $ blake2b_256 $ - getTxId (txOutRefId firstInput) <> "#" <> getIdent (intToIdent (txOutRefIdx firstInput)) - !poolOutput = uniqueElement' $ - filter (\case - TxOut{txOutAddress, txOutValue} - | valueContains txOutValue ocs (computePoolTokenName newPoolIdent) - , txOutAddress == scriptHashAddress poolSH - -> True - _ -> False - ) (txInfoOutputs txInfo) - !poolOutputValue = txOutValue poolOutput - !poolOutputValueSansRider = sansRider poolOutputValue - !initialLiquidityTokens = - computeInitialLiquidityTokens - (valueOfAC poolOutputValueSansRider coinA) - (valueOfAC poolOutputValueSansRider coinB) - in - debug "coin pair not in canonical ordering, alphanumeric by policyID and assetName" - (coinA < coinB) && - debug "minted something other than: a single pool token + correct amount of initial liquidity" ( - txInfoMint txInfo == Value ( - Map.singleton ocs $ Map.fromList - [ (computePoolTokenName newPoolIdent, 1) - , (computeLiquidityTokenName newPoolIdent, initialLiquidityTokens) - ] - )) && - debug "liquidity and/or pool NFT not spent to pool" - ( valueOfAC poolOutputValueSansRider coinA >= 1 && - valueOfAC poolOutputValueSansRider coinB >= 1 && - hasLimitedNft 3 (toPoolNft ocs newPoolIdent) poolOutputValueSansRider ) && - debug "pool datum not properly initialized" - (case datumOf txInfo poolOutput of - Just PoolDatum{..} -> - _pool'coins == AB coinA coinB && - _pool'poolIdent == newPoolIdent && - _pool'circulatingLP == initialLiquidityTokens && - elem _pool'swapFees legalSwapFees - Nothing -> error () - ) - where - ScriptContext txInfo (Minting ocs) = unsafeFromBuiltinData rawCtx - ins = txInfoInputs txInfo - !factoryReference = uniqueElement' - [ o - | o <- txInfoReferenceInputs txInfo - , isFactory fbcs (txInInfoResolved o) - ] - !factoryReferenceDatum = - case datumOf txInfo (txInInfoResolved factoryReference) of - Just fac -> (fac :: FactoryDatum) - Nothing -> traceError "factory reference must have a factory datum" - !(FactoryDatum !poolSH _poolCS _ _) = factoryReferenceDatum diff --git a/onchain/Sundae/Contracts/Pool.hs b/onchain/Sundae/Contracts/Pool.hs deleted file mode 100644 index 2a0d7de..0000000 --- a/onchain/Sundae/Contracts/Pool.hs +++ /dev/null @@ -1,398 +0,0 @@ -module Sundae.Contracts.Pool where - -import qualified Prelude -import PlutusTx.Prelude -import PlutusTx.Sqrt -import PlutusTx.Numeric - -import PlutusLedgerApi.V2 -import PlutusLedgerApi.V1.Value -import PlutusLedgerApi.V2.Contexts (findOwnInput) - -import qualified PlutusTx.AssocMap as Map -import PlutusTx.Ratio -import PlutusTx.Builtins - -import Sundae.Contracts.Common -import Sundae.Utilities -import PlutusLedgerApi.V1.Address (stakingCredential) - -{-# inlineable sortOn #-} -sortOn :: Ord b => (a -> b) -> [a] -> [a] -sortOn f = - map snd . sortBy (comparing fst) . map (\x -> let y = f x in {-y `seq`-} (y, x)) - -{-# inlineable comparing #-} -comparing :: (Ord a) => (b -> a) -> b -> b -> Ordering -comparing p x y = compare (p x) (p y) - -data EscrowWithFee = EscrowWithFee - { fee :: !Integer - , escrow :: {-# UNPACK #-} !(EscrowDestination, EscrowAction) - } - -data OrderedEscrow = OrderedEscrow - { index :: !Integer - , escrowWithFee :: {-# UNPACK #-} !EscrowWithFee - } - --- Pool contract --- Holds community liquidity, brokers swaps via a market maker formula via aggregating many operations --- Parameterized by: --- FactoryBootCurrencySymbol, to identify scooper licenses --- PoolCurrencySymbol, to identify the Pool NFT --- ScooperFeeHolderScriptHash, to identify where scooper rewards should be paid --- Uses Datum: --- coins, identifier, issued liquidity, fee rate --- Allows (via Redeemer): --- PoolScoop - Take a bunch of aggregated orders and enact them all --- PoolUpgrade - Move the liquidity into a new script, when blessed by a proposal token --- Details: --- The pool is here for one thing: executing escrowed operations at a price --- dictated by the pool's asset amounts. Notably, we assume that all script --- inputs other than the pool itself are escrow inputs, because it lets us --- avoid a circular dependency. --- If you want to scoop the pool, you need a license token. You can get that --- from the factory contract, if you're authorized. We have the scoop --- redeemer tell us when the license was issued, because that helps us find --- the token in the inputs. - -{-# inlinable poolContract #-} -poolContract - :: FactoryBootCurrencySymbol - -> EscrowScriptHash - -> PoolDatum - -> PoolRedeemer - -> ScriptContext - -> Bool -poolContract (FactoryBootCurrencySymbol fbcs) _ - (datum@(PoolDatum coins@(AB coinA coinB) poolIdent oldCirculatingLP swapFees marketOpenTime rewards)) - (PoolScoop scooperPkh order) - ctx = - let - !init = ABL (valueOfAC oldValueSansRider coinA) (valueOfAC oldValueSansRider coinB) oldCirculatingLP - !(ScoopResult cons newAmtA newAmtB newCirculatingLP) = - doEscrows poolIdent coinA coinB swapFees init - (escrow . escrowWithFee <$> sortOn index (zipWith OrderedEscrow order escrows)) - in - debug "must have escrows" - (not $ null escrows) && - _pool'circulatingLP newDatum == newCirculatingLP && - newRewardsAmt >= rewards + minimumScooperFee && - debug "extra outputs not spent" - (all' mustSpendTo (mergeListByKey cons)) && - debug "issued amount does not match minted amount" - ( if newCirculatingLP == oldCirculatingLP - then null (flattenValue' (txInfoMint txInfo)) - else onlyHas (txInfoMint txInfo) poolCS (computeLiquidityTokenName poolIdent) (== (newCirculatingLP - oldCirculatingLP)) - ) && - debug "pool output (excluding the rider) must contain exactly: coin a, coin b, an NFT" - (hasLimitedNft 3 (toPoolNft poolCS poolIdent) poolOutputFunds) && - debug "pool output does not include all expected liquidity" - (valueOfAC poolOutputFunds coinA == newAmtA && - valueOfAC poolOutputFunds coinB == newAmtB) && - debug "must be a licensed scooper" - (elem scooperPkh scoopers) && - debug "no swaps allowed before marketOpenTime" - ( if earliest < marketOpenTime - then all nonSwap escrows - else True - ) && - debug "staking key must be allowed" - (case poolOutput of - TxOut{txOutAddress=Address _ (Just newStakingCred)} -> newStakingCred `elem` stakerKeySet - TxOut{txOutAddress=Address _ Nothing} -> True - ) - where - Just !newDatum = datumOf txInfo poolOutput - !newRewardsAmt = _pool'rewards newDatum - nonSwap (EscrowWithFee fee (_, escrowAction)) = - case escrowAction of - EscrowSwap _ _ -> False - _ -> True - !(LowerBound (Finite earliest) _) = ivFrom (txInfoValidRange txInfo) - !factoryReference = uniqueElement' - [ o - | o <- txInfoReferenceInputs txInfo - , isFactory fbcs (txInInfoResolved o) - ] - !factoryReferenceDatum = - case datumOf txInfo (txInInfoResolved factoryReference) of - Just fac -> fac - Nothing -> traceError "factory reference must have a factory datum" - !(FactoryDatum _poolSH !poolCS !scoopers !stakerKeySet) = factoryReferenceDatum - UpperBound (Finite latest) _ = ivTo (txInfoValidRange txInfo) - - !ownInput = scriptInput ctx - !poolOutput = uniqueElement' - [ o - | o <- txInfoOutputs txInfo - , isScriptAddress o ownScriptHash - ] - poolOutputValue = txOutValue poolOutput - !poolOutputFunds = sansAda (newRewardsAmt + riderAmount) poolOutputValue - mustSpendTo (EscrowDestination addr dh, val, count) = - atLeastOneSpending addr dh val count (txInfoOutputs txInfo) - atLeastOneSpending :: Address -> Maybe DatumHash -> ABL Integer -> Integer -> [TxOut] -> Bool - atLeastOneSpending _ _ _ _ [] = False - atLeastOneSpending addr dh val count ((o@TxOut{txOutAddress, txOutValue}) : tl) - | eqAddrCredential txOutAddress addr - , txOutDatumHash o == dh - -- Since every escrow input has a rider, we require every output to have a rider as well - -- By subtracting it off here, it ensures you're getting all the funds you're entitled to - -- according to doEscrows - , let !txOutSansRider = sansRider' count txOutValue - , val $$ CoinA <= valueOfAC txOutSansRider coinA - , val $$ CoinB <= valueOfAC txOutSansRider coinB - , liquidity val <= valueOfAC txOutSansRider liquidityAssetClass = True - | otherwise = atLeastOneSpending addr dh val count tl - !txInfo = scriptContextTxInfo ctx - liquidityAssetClass = - AssetClass (poolCS, computeLiquidityTokenName poolIdent) - !totalScooperFee = foldl' (\a (EscrowWithFee f _) -> a + f) zero escrows - !minimumScooperFee = max 0 (totalScooperFee - valueOf (txInfoFee txInfo) adaSymbol adaToken) - !escrows = - [ EscrowWithFee scoopFee (fromEscrowAddress ret, act) - | TxInInfo {txInInfoResolved = txOut} <- txInfoInputs txInfo - , let !escrowInValue = txOutValue txOut - -- Escrows will usually come from the escrow script, but it's OK if they - -- come from somewhere else as long as the datum is valid. Other scripts - -- might be useful to provide other conditions for escrows, such as stop - -- loss orders. So we treat anything that doesn't come from the pool script - -- as an escrow. - , not (isScriptAddress txOut ownScriptHash) - , Just (EscrowDatum ret scoopFee act) <- [datumOf txInfo txOut] - , scoopFee >= 0 - -- Coin B can never be ADA, because pool coin pairs are lexicographically - -- ordered when we create a pool, so we only check A here - -- NOTE: this enforces that the escrow *always* has at least 2 ada on the rider, - -- meaning you can't under-spend your rider and get 2ADA back - , valueOf (sansAmountA escrowInValue act) adaSymbol adaToken >= scoopFee + riderAmount - , if checkAction escrowInValue act - then True - else die "escrow incorrect" - ] - oldValue = txOutValue ownInput - ownScriptHash = - case ownInput of - (TxOut (Address (ScriptCredential h) _) _ _ _) -> h - _ -> traceError "invalid pool script utxo" - amountA = \case - EscrowDeposit _ (DepositMixed (AB amtA _)) -> amtA - EscrowDeposit _ (DepositSingle CoinA amt) -> amt - EscrowDeposit _ (DepositSingle CoinB _) -> 0 - EscrowWithdraw _ _ -> 0 - EscrowSwap (giveCoin, amt) _ | giveCoin == coinA -> amt - EscrowSwap _ _ -> 0 - sansAmountA v act = - let - AssetClass (coinASymbol, coinAToken) = coinA - coinAValue = valueOfAC v coinA - in - Value $ Map.insert - coinASymbol - (Map.singleton coinAToken (coinAValue - amountA act)) - (getValue v) - -- Subtract off the ADA rider; - -- If we don't do this, ADA/X pools, this can screw up the price calculation - -- Normally, the amount of ada in the pool should be able to asymptotically approach 0 as the price of ADA goes up - -- With the added rider, it asymptotically approaches 2; if we don't subtract off the rider, then - -- There might be a hard limit on how much the pool can be traded - !oldValueSansRider = sansAda (rewards + riderAmount) oldValue - checkAction !(sansRider -> v) = \case - EscrowDeposit _ (DepositMixed (AB amtA amtB)) -> - valueOfAC v coinA >= amtA && valueOfAC v coinB >= amtB && amtA >= 1 && amtB >= 1 - EscrowDeposit _ (DepositSingle coin amt) -> - valueOfAC v (coins $$ coin) >= amt && amt >= 1 - EscrowWithdraw _ amt -> - valueOfAC v liquidityAssetClass >= amt && amt >= 1 - EscrowSwap (giveCoin, amt) _ -> - valueOfAC v giveCoin >= amt && amt >= 1 - --- Escrow contract --- Lock user funds, with an order to execute against a pool --- Parameterized by: --- PoolCurrencySymbol, to identify the pool NFT allowed to spend the funds --- Uses Datum: --- Pool to execute against, A return destination, an alternate cancel address, what action to perform --- Return destination can be either a wallet address, or a script address + datum hash --- Allows (via Redeemer): --- EscrowScoop - execute the order against a pool --- EscrowCancel - cancel the order, returning the funds -{-# inlinable escrowContract #-} -escrowContract - :: SteakScriptHash - -> BuiltinData -- EscrowDatum - -> BuiltinData -- EscrowRedeemer - -> BuiltinData -- ScriptContext - -> Bool -escrowContract - (SteakScriptHash steakScriptHash) - (unsafeFromBuiltinData -> escrow_datum) - (unsafeFromBuiltinData -> redeemer) - rawCtx = - case redeemer of - EscrowScoop -> - escrowScoop - EscrowCancel -> - escrowCancel - where - escrowScoop = - debug "must invoke steak contract" - (case withdrawals of - [] -> False - ((w, _):_) -> - case unsafeFromBuiltinData w of - StakingHash (ScriptCredential s) -> s == steakScriptHash - _ -> False) - escrowCancel = - debug "the canceller did not sign the transaction" - (atLeastOne (\x -> atLeastOne (\a -> unsafeFromBuiltinData a == x) signatories) pkhs) - where - !(EscrowDatum escrow_addr _ _) = escrow_datum - pkhs = escrowPubKeyHashes escrow_addr - (unsafeDataAsConstr -> (_, [ - (unsafeDataAsConstr -> (_, [ - _, _, _, _, _, _, - unsafeDataAsMap -> withdrawals, - _, - unsafeDataAsList -> signatories, - _, _, _ - ])), _])) = rawCtx - -{-# inlinable steakContract #-} -steakContract - :: PoolCurrencySymbol - -> BuiltinData - -> BuiltinData - -> Bool -steakContract (PoolCurrencySymbol pcs) _ rawCtx = - debug "no pool nft found" - (atLeastOne (hasPoolToken . txOutValue . unsafeFromBuiltinData) outs) - where - hasPoolToken :: Value -> Bool - hasPoolToken v = any isPoolNft (flattenValue v) - isPoolNft :: (CurrencySymbol, TokenName, Integer) -> Bool - isPoolNft (cs, TokenName tk, n) = cs == pcs && takeByteString 1 tk == "p" - (unsafeDataAsConstr -> (_, [ - (unsafeDataAsConstr -> (_, [ - _, _, - unsafeDataAsList -> outs, - _, _, _, _, _, _, _, _, _ - ])), _])) = rawCtx - -data ScoopResult = ScoopResult - { poolCons :: ![(EscrowDestination, ABL Integer)] - , scoopResultA :: !Integer - , scoopResultB :: !Integer - , scoopResultLiquidity :: !Integer - } deriving Prelude.Show - -instance Pairlike () ScoopResult Integer where - {-# inline conlike ofCoin #-} - x `ofCoin` CoinA = ScoopResult [] x zero zero - x `ofCoin` CoinB = ScoopResult [] zero x zero - {-# inlinable ($$) #-} - so $$ CoinA = scoopResultA so - so $$ CoinB = scoopResultB so - -{-# inlinable unsafeSqrt #-} -unsafeSqrt :: Rational -> Integer -unsafeSqrt !r = case rsqrt r of - Exactly i -> i - Approximately i -> i - Imaginary -> error () - --- Compute the result of processing one or more escrows against the pool. The --- result is the same as if we processed each escrow in an independent --- transaction -{-# inlinable doEscrows #-} -doEscrows - :: BuiltinByteString - -> AssetClass - -> AssetClass - -> SwapFees - -> ABL Integer - -> [(EscrowDestination, EscrowAction)] - -> ScoopResult -doEscrows poolId poolCoinA poolCoinB (SwapFees swapFees) !initialState !escrows = - go (initialState $$ CoinA) (initialState $$ CoinB) (liquidity initialState) [] escrows - where - go !a !b !liq !cons ((ret,act):es) = case act of - EscrowWithdraw withdrawId givesLiquidity -> - if withdrawId == poolId then - doWithdrawal ret givesLiquidity a b liq cons es - else - error () - EscrowSwap (giveAC, gives) (takeAC, minTakes) -> - let - !de = denominator swapFees - !nu = numerator swapFees - !diff = de - nu - in - if giveAC == poolCoinA && takeAC == poolCoinB then - let - !takes = (b * gives * diff) `divide` (a * de + gives * diff) - in - if b > takes && Just takes >= minTakes then - go (a + gives) (b - takes) liq ((ret, takes `ofCoin` CoinB) : cons) es - else - error () - else if giveAC == poolCoinB && takeAC == poolCoinA then - let - !takes = (a * gives * diff) `divide` (b * de + gives * diff) - in - if a > takes && Just takes >= minTakes then - go (a - takes) (b + gives) liq ((ret, takes `ofCoin` CoinA) : cons) es - else - error () - else - error () - EscrowDeposit depositId dep -> - if depositId == poolId then - doDeposit ret dep a b liq cons es - else - error () - go a b liq cons [] = ScoopResult cons a b liq - - -- similar to the balancer formula - doDeposit ret (DepositSingle coin amt) a b liq cons es = - let - de = denominator swapFees * 2 - nu = numerator swapFees - diff = de - nu - inPool CoinA = a - inPool CoinB = b - !liq2 = liq * liq - !extraLiquidityTokens = - unsafeSqrt - (fromInteger liq2 + (liq2 * amt * diff) % (inPool coin * de)) - - liq - !liq_incr = liq + extraLiquidityTokens - !liqABL = ofLiquidity extraLiquidityTokens - in - case coin of - CoinA -> - go (a + amt) b liq_incr ((ret, liqABL) : cons) es - CoinB -> - go a (b + amt) liq_incr ((ret, liqABL) : cons) es - doDeposit ret (DepositMixed userGives) a b liq cons es = - let !bInUnitsOfA = (userGives $$ CoinB * a) `divide` b - !giveCoinA = userGives $$ CoinA - !change = - if bInUnitsOfA > giveCoinA then - ((b * (bInUnitsOfA - giveCoinA)) `divide` a) `ofCoin` CoinB - else - (giveCoinA - bInUnitsOfA) `ofCoin` CoinA - !userDeposits = noLiquidity (userGives - change) - !extraLiquidityTokens = (userDeposits $$ CoinA * liq) `divide` a - !output = ofLiquidity extraLiquidityTokens + noLiquidity change - in - go (a + userDeposits $$ CoinA) (b + userDeposits $$ CoinB) (liq + extraLiquidityTokens) ((ret, output) : cons) es - - doWithdrawal ret givesLiquidity a b liq cons es = - let - inPool CoinA = a - inPool CoinB = b - !withdrawn = noLiquidity $ memo \coin -> (givesLiquidity * inPool coin) `divide` liq - in go (a - withdrawn $$ CoinA) (b - withdrawn $$ CoinB) (liq - givesLiquidity) ((ret, withdrawn) : cons) es diff --git a/onchain/Sundae/ShallowData.hs b/onchain/Sundae/ShallowData.hs deleted file mode 100644 index 8bbca91..0000000 --- a/onchain/Sundae/ShallowData.hs +++ /dev/null @@ -1,215 +0,0 @@ -{-# options_ghc -fexpose-all-unfoldings #-} -{-# language PatternSynonyms #-} -{-# language ViewPatterns #-} -{-# language TemplateHaskell #-} -{-# language TypeApplications #-} -{-# language FunctionalDependencies #-} -{-# language DerivingStrategies #-} -{-# language GeneralizedNewtypeDeriving #-} -{-# language DefaultSignatures #-} -module Sundae.ShallowData where - -import qualified PlutusLedgerApi.V1.Address as Ledger -import qualified PlutusLedgerApi.V1.Credential as Ledger -import qualified PlutusLedgerApi.V1.Value as Ledger -import qualified PlutusLedgerApi.V1.Scripts as Ledger -import qualified PlutusLedgerApi.V1.Crypto as Ledger -import qualified PlutusLedgerApi.V1.Time as Ledger -import qualified PlutusLedgerApi.V1.DCert as Ledger - -import PlutusTx -import Data.Coerce -import PlutusTx.Prelude -import PlutusTx.Builtins ---import Language.Haskell.TH.Syntax (Q, TExp) - --- We optimize a few scripts by only deserializing *part* of their --- ScriptContext's from the `Data` that they're given. This file lets us do --- that in a type-safe way. The serialization schema of ScriptContext is fixed, --- which justifies this optimization. - --- This stuff is kind of gross. We'd like to use a data family for the --- unwrapped version of each type. Unfortunately, those aren't supported by --- `makeIsDataIndexed` and such. Barring that, we'd like to use a type family to link --- each typed to its unwrapped version. That's not supported by the Plutus --- compiler. We'd really like to use pattern synonyms. Their desugaring uses --- features that, again, are not supported by Plutus. It would also be very --- nice to be able to generate all this stuff automagically. But the Template --- Haskell name munging sounds a little tricky, and we'd need to use manually --- constructed `makeIsDataIndexed` instances regardless, since there's no --- remotely simple way to work out what those should look like. - -class Unwrappable a b | a -> b, b -> a - -{-# INLINE unwrap #-} -unwrap :: (Goercible a, UnsafeFromData b, Unwrappable a b) => a -> b -unwrap = unsafeFromBuiltinData . goerce - -class Goercible a where - goerce :: a -> BuiltinData - -- I can't seem to get an unfolding for the obvious goerce = coerce implementation. - -- *sigh* - -newtype Datum = Datum__ BuiltinData - deriving newtype (UnsafeFromData, ToData, FromData) -instance Goercible Datum where goerce = coerce -makeLift ''Datum -instance Unwrappable Datum Ledger.Datum - -newtype DatumHash = DatumHash__ BuiltinData - deriving newtype (UnsafeFromData, ToData, FromData) -instance Goercible DatumHash where goerce = coerce -makeLift ''DatumHash -instance Unwrappable DatumHash Ledger.DatumHash - -newtype PubKeyHash = PubKeyHash__ BuiltinData - deriving newtype (UnsafeFromData, ToData, FromData, Eq) -instance Goercible PubKeyHash where goerce = coerce -makeLift ''PubKeyHash -instance Unwrappable PubKeyHash Ledger.PubKeyHash - -newtype POSIXTimeRange = POSIXTimeRange__ BuiltinData - deriving newtype (UnsafeFromData, ToData, FromData) -instance Goercible POSIXTimeRange where goerce = coerce -makeLift ''POSIXTimeRange -instance Unwrappable POSIXTimeRange Ledger.POSIXTimeRange - -newtype DCert = DCert__ BuiltinData - deriving newtype (UnsafeFromData, ToData, FromData) -instance Goercible DCert where goerce = coerce -makeLift ''DCert -instance Unwrappable DCert Ledger.DCert - -newtype Value = Value__ BuiltinData - deriving newtype (Eq, UnsafeFromData, ToData, FromData) -instance Goercible Value where goerce = coerce -makeLift ''Value -instance Unwrappable Value Ledger.Value - -newtype Credential = Credential__ BuiltinData - deriving newtype (UnsafeFromData, ToData, FromData) -instance Goercible Credential where goerce = coerce -makeLift ''Credential -instance Unwrappable Credential Ledger.Credential - -newtype StakingCredential = StakingCredential__ BuiltinData - deriving newtype (Eq, UnsafeFromData, ToData, FromData) -instance Goercible StakingCredential where goerce = coerce -instance Unwrappable StakingCredential Ledger.StakingCredential - -newtype Address = Address__ BuiltinData - deriving newtype (Eq, UnsafeFromData, ToData, FromData) -instance Goercible Address where goerce = coerce --- data Address__U = Address{ addressCredential :: Credential, addressStakingCredential :: Maybe StakingCredential } --- PlutusTx.makeIsDataIndexed ''Address__U [('Address,0)] -instance Unwrappable Address Ledger.Address - -newtype TxId = TxId__ BuiltinData - deriving newtype (Eq, UnsafeFromData, ToData, FromData) -instance Goercible TxId where goerce = coerce -newtype TxId__U = TxId { getTxId :: BuiltinByteString } -makeIsDataIndexed ''TxId__U [('TxId,0)] - -newtype TxOutRef = TxOutRef__ BuiltinData - deriving newtype (Eq, UnsafeFromData, ToData, FromData) -instance Goercible TxOutRef where goerce = coerce -makeLift ''TxOutRef - -data TxOutRef__U = TxOutRef { - txOutRefId :: TxId, - txOutRefIdx :: Integer -- ^ Index into the referenced transaction's outputs - } -PlutusTx.makeIsDataIndexed ''TxOutRef__U [('TxOutRef,0)] - -instance Eq TxOutRef__U where - {-# inlinable (==) #-} - TxOutRef i idx == TxOutRef i' idx' - | i == i' - , idx == idx' = True - | otherwise = False -instance Unwrappable TxOutRef TxOutRef__U - -newtype TxOut = TxOut__ BuiltinData - deriving newtype (Eq, UnsafeFromData, ToData, FromData) -instance Goercible TxOut where goerce = coerce -data TxOut__U = TxOut { - txOutAddress :: Address, - txOutValue :: Value, - txOutDatumHash :: Maybe Ledger.DatumHash - } -instance Unwrappable TxOut TxOut__U -PlutusTx.makeIsDataIndexed ''TxOut__U [('TxOut,0)] - -newtype TxInInfo = TxInInfo__ BuiltinData - deriving newtype (Eq, UnsafeFromData, ToData, FromData) -instance Goercible TxInInfo where goerce = coerce - -data TxInInfo__U = TxInInfo - { txInInfoOutRef :: TxOutRef - , txInInfoResolved :: TxOut - } -instance Unwrappable TxInInfo TxInInfo__U -makeIsDataIndexed ''TxInInfo__U [('TxInInfo,0)] - -newtype DeferredPair a b = DeferredPair__ BuiltinData - deriving newtype (UnsafeFromData, ToData, FromData) -instance Goercible (DeferredPair a b) where goerce = coerce -data DeferredPair__U a b = DeferredPair a b -PlutusTx.makeIsDataIndexed ''DeferredPair__U [('DeferredPair,0)] -instance Unwrappable (DeferredPair a b) (DeferredPair__U a b) - -newtype TxInfo = TxInfo__ BuiltinData - deriving newtype (UnsafeFromData, ToData, FromData) -instance Goercible TxInfo where goerce = coerce -data TxInfo__U = TxInfo - { txInfoInputs :: [TxInInfo] -- ^ Transaction inputs - , txInfoOutputs :: [TxOut] -- ^ Transaction outputs - , txInfoFee :: Value -- ^ The fee paid by this transaction. - , txInfoMint :: Value -- ^ The 'Value' minted by this transaction. - , txInfoDCert :: [DCert] -- ^ Digests of certificates included in this transaction - , txInfoWdrl :: [DeferredPair StakingCredential Integer] -- ^ Withdrawals - , txInfoValidRange :: POSIXTimeRange -- ^ The valid range for the transaction. - , txInfoSignatories :: [PubKeyHash] -- ^ Signatures provided with the transaction, attested that they all signed the tx - , txInfoData :: [DeferredPair DatumHash Datum] - , txInfoId :: TxId - -- ^ Hash of the pending transaction (excluding witnesses) - } -instance Unwrappable TxInfo TxInfo__U -instance UnsafeFromData TxInfo__U where - unsafeFromBuiltinData (unsafeDataAsConstr -> - (_, [inputs, outputs, fee, mint, dcert, wdrl, vrng, signts, infdat, infid])) - = TxInfo (coerce (unsafeDataAsList inputs)) (coerce (unsafeDataAsList outputs)) (coerce fee) (coerce mint) (coerce (unsafeDataAsList dcert)) (coerce (unsafeDataAsList wdrl)) - (coerce vrng) (coerce (unsafeDataAsList signts)) (coerce (unsafeDataAsList infdat)) (coerce infid) - unsafeFromBuiltinData _ = traceError "Unexpected TxInfo construction." - -newtype ScriptPurpose = ScriptPurpose__ BuiltinData - deriving newtype (Eq, UnsafeFromData, ToData, FromData) - -instance Goercible ScriptPurpose where goerce = coerce - -data ScriptPurpose__U - = Minting Ledger.CurrencySymbol - | Spending TxOutRef - -- | ... - -instance Unwrappable ScriptPurpose ScriptPurpose__U -makeIsDataIndexed ''ScriptPurpose__U [('Minting,0), ('Spending,1)] - -newtype ScriptContext = ScriptContext__ BuiltinData - deriving newtype (Eq, UnsafeFromData, ToData,FromData) -instance Goercible ScriptContext where goerce = coerce -makeLift ''ScriptContext - -data ScriptContext__U - = ScriptContext - { scriptContextTxInfo :: TxInfo - , scriptContextPurpose :: ScriptPurpose - } -instance Unwrappable ScriptContext ScriptContext__U -makeIsDataIndexed ''ScriptContext__U [('ScriptContext,0)] - -grum :: BuiltinData -> (TxInfo, ScriptPurpose) -grum (unwrap . unsafeFromBuiltinData -> ScriptContext info purpose) = (info, purpose) - -potato :: CompiledCode (BuiltinData -> (TxInfo, ScriptPurpose)) -potato = $$(compile [|| grum ||]) diff --git a/onchain/Sundae/Utilities.hs b/onchain/Sundae/Utilities.hs deleted file mode 100644 index e4c2a20..0000000 --- a/onchain/Sundae/Utilities.hs +++ /dev/null @@ -1,486 +0,0 @@ -{-# Language InstanceSigs #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Sundae.Utilities where - -import PlutusTx.Prelude -import PlutusTx.Builtins -import qualified PlutusTx -import qualified Prelude hiding (foldMap) - -import PlutusLedgerApi.V1.Value -import PlutusLedgerApi.V1.Time - -import Data.Aeson qualified as Aeson -import Data.ByteString.Base16 qualified as Base16 - -import PlutusCore qualified as Core -import PlutusTx.AssocMap(Map) -import qualified PlutusTx.AssocMap as Map - -import Control.DeepSeq -import Data.Aeson hiding (Value) -import Data.Coerce -import GHC.Generics - -import Data.Text.Encoding qualified as Encoding - -import qualified System.Random as Random - -import PlutusLedgerApi.V2 -import PlutusLedgerApi.V2.Contexts - -{-# inlinable scriptHashAddress #-} -scriptHashAddress :: ScriptHash -> Address -scriptHashAddress sh = Address (ScriptCredential sh) Nothing - -{- -findOwnInput :: ScriptContext -> Maybe TxInInfo -findOwnInput (ScriptContext t_info (Spending o_ref)) = - let - go (this@(TxInInfo tref ot) : tl) o_ref - | tref == o_ref = Just this - | otherwise = go tl o_ref - go [] _ = Nothing - in - go (txInfoInputs t_info) o_ref --} - -{-# inlinable getContinuingOutputs #-} -getContinuingOutputs :: ScriptContext -> [TxOut] -getContinuingOutputs ctx = - case findOwnInput ctx of - Just TxInInfo{txInInfoResolved=TxOut{txOutAddress}} -> filter (f txOutAddress) (txInfoOutputs $ scriptContextTxInfo ctx) - Nothing -> traceError "Lf" - where - f addr TxOut{txOutAddress=otherAddress} = addr == otherAddress - --- These instances were dropped, so we now have to implement them --- but they won't be used in contracts -instance ToJSON BuiltinByteString where - toJSON bs = toJSON (Encoding.decodeUtf8 (Base16.encode (fromBuiltin bs))) -instance FromJSON BuiltinByteString where - parseJSON = withText "BuiltinByteString" $ \s -> - case Base16.decode (Encoding.encodeUtf8 s) of - Right rawBytes -> Prelude.pure (toBuiltin rawBytes) - Left err -> Prelude.fail err - -{-# inlinable atLeastOne #-} -atLeastOne :: (a -> Bool) -> [a] -> Bool -atLeastOne f (x:xs) = if f x then True else atLeastOne f xs -atLeastOne _ [] = False - -{-# inlinable toDiffMilliSeconds #-} -toDiffMilliSeconds :: POSIXTime -> DiffMilliSeconds -toDiffMilliSeconds = coerce - -{-# inlinable lovelaceOf #-} -lovelaceOf :: Value -> Integer -lovelaceOf v = valueOf v adaSymbol adaToken - -{-# inlinable hasLimitedNft #-} -hasLimitedNft :: Integer -> AssetClass -> Value -> Bool -hasLimitedNft size coin val = - valueOfAC val coin == 1 && valueSizeLimited size val - -{-# inlinable length' #-} -length' :: [a] -> Integer -length' l = go l 0 - where - go [] acc = acc - go (_: tl) acc = go tl (acc + 1) - - -{-# inlinable flattenValue' #-} -flattenValue' :: Value -> [(CurrencySymbol, TokenName, Integer)] -flattenValue' v = go (Map.toList $ getValue v) [] - where - go [] acc = acc - go ((cs, m) : tl) acc = go tl $ flatten_l cs (Map.toList m) acc - - flatten_l _ [] acc = acc - flatten_l cs ((tn, a) : tl) acc - | a /= 0 = flatten_l cs tl ((cs, tn, a) : acc) - | otherwise = flatten_l cs tl acc - -{-# inlinable valueSizeLimited #-} -valueSizeLimited :: Integer -> Value -> Bool -valueSizeLimited size val = - length' (flattenValue' val) <= size - -{-# inlinable valueOfAC #-} -valueOfAC :: Value -> AssetClass -> Integer -valueOfAC = assetClassValueOf - -{-# inlinable noSymbol #-} --- | Value does not contain currency symbol -noSymbol :: CurrencySymbol -> Value -> Bool -noSymbol cs (Value val) = - maybe True (== Map.empty) (Map.lookup cs val) - -{-# inlinable withoutLovelace #-} -withoutLovelace :: Value -> Value -withoutLovelace v = - Value $ Map.fromList $ filter (\(k, _) -> k /= adaSymbol) $ Map.toList $ getValue v - -{-# inlinable datumOf #-} --- | It only succeeds if there's a valid datum, or fails on a missing datum. --- If there's an invalid datum, you get a crash. -datumOf :: FromData a => TxInfo -> TxOut -> Maybe a -datumOf txInfo txOut = do - d <- getDatum <$> rawDatumOf txInfo txOut - fromBuiltinData d - -{-# inlinable rawDatumOf #-} -rawDatumOf :: TxInfo -> TxOut -> Maybe Datum -rawDatumOf txInfo txOut = - case txOutDatum txOut of - OutputDatumHash d -> Map.lookup d $ txInfoData txInfo - OutputDatum d -> Just d - NoOutputDatum -> Nothing - -txOutDatumHash :: TxOut -> Maybe DatumHash -txOutDatumHash txOut = - case txOutDatum txOut of - OutputDatumHash d -> Just d - OutputDatum _ -> Nothing - NoOutputDatum -> Nothing - --- More efficient alternative to findDatum from Plutus V1. Consider changing --- back to findDatum if we upgrade to Plutus V2 -{-# inlinable searchDatum #-} -searchDatum :: DatumHash -> [(DatumHash, Datum)] -> Maybe BuiltinData -searchDatum _ [] = Nothing -searchDatum dsh ((dsh', Datum d) : tl) - | dsh == dsh' = Just d - | otherwise = searchDatum dsh tl - -{-# inlinable isDatumUnsafe #-} -isDatumUnsafe :: ToData a => TxInfo -> TxOut -> a -> Bool -isDatumUnsafe txInfo txOut expectedDat = - rawDatumOf txInfo txOut == Just (Datum (toBuiltinData expectedDat)) - -{-# INLINABLE getAddressOutputs #-} -getAddressOutputs :: ScriptContext -> Address -> [TxOut] -getAddressOutputs ctx addr = filter f (txInfoOutputs $ scriptContextTxInfo ctx) - where - f TxOut{txOutAddress=otherAddress} = addr == otherAddress - -{-# inlinable debug #-} -debug :: BuiltinString -> Bool -> Bool -debug = - -- const id - traceIfFalse - -{-# inlinable die #-} -die :: BuiltinString -> a -die = - -- const (error ()) - traceError - --- the Plutus version of this makes little sense, because it requires that *all* --- assets are greater in number, rather than just requiring that just one is, --- and the rest are greater or equal. this may be possible to optimize. -{-# inlinable valueGT #-} -valueGT :: Value -> Value -> Bool -valueGT v1 v2 = - atLeastOne (\(cs,tk,n) -> n > valueOf v2 cs tk) (flattenValue v1) && v1 `geq` v2 - -{-# inlinable all' #-} -all' :: _ -all' f = go - where - go (x:xs) = if f x then go xs else False - go [] = True - -{-# inlinable foldl' #-} -foldl' :: _ -foldl' f = go - where - go !z (x:xs) = go (f z x) xs - go z [] = z - --- An optimization over `uniqueElement` from the Plutus stdlib. -{-# inlinable uniqueElement' #-} -uniqueElement' :: [a] -> a -uniqueElement' [x] = x -uniqueElement' _ = error () - --- `Ident`, named for its most frequent use as an identifier, is basically an --- `Integer` encoded as a `ByteString`, because Plutus offers no way to do this --- in its standard library. -newtype Ident = Ident BuiltinByteString - deriving stock (Generic) - deriving anyclass (NFData) - deriving newtype (ToJSON, FromJSON) - deriving anyclass (ToJSONKey, FromJSONKey) - deriving newtype (Prelude.Eq, Prelude.Show, Prelude.Ord) - deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) - ---deriving instance NFData Rational -instance NFData Rational where - rnf !_ = () - -deriving newtype instance FromJSON DiffMilliSeconds -deriving newtype instance ToJSON DiffMilliSeconds - -instance Eq Ident where - {-# inlinable (==) #-} - Ident i == Ident i' = i == i' - -PlutusTx.makeLift ''Ident - -{-# inlinable initialIdent #-} -initialIdent :: Ident -initialIdent = Ident $ consByteString 0 "" - -{-# inline identBase #-} -identBase :: Integer -identBase = 256 - -{-# inlinable succIdent #-} -succIdent :: Ident -> Ident -succIdent = succsIdent 1 - -{-# inlinable intToIdent #-} -intToIdent :: Integer -> Ident -intToIdent n = succsIdent n initialIdent - --- | Ident is chain of bytes written in reverse. It grows like this: --- > 0, 1, ... --- > 01, 11, 21 ... --- > 001, 101, 201, 301 ... --- --- only it uses bytes not 10-digit base system. So the base is 256. -{-# inlinable succsIdent #-} -succsIdent :: Integer -> Ident -> Ident -succsIdent !count (Ident ident) = Ident $ add (lengthOfByteString ident) ident count - where - add len str n - | n <= 0 = str - | len <= 0 = consByteString m (addRest d) - | otherwise = let cur = m + indexByteString str 0 - rest = dropByteString 1 str -- OPTIMIZATION: Slicing? - (d', m') = divMod cur identBase - in consByteString m' (add (len - 1) rest (d + d')) - where - (d, m) = divMod n identBase - - -- if string is over and we need to append number to the tail of the identifier - addRest n - | n == 0 = "" - | otherwise = consByteString m (addRest d) - where - (d, m) = divMod n identBase - -{-# inlineable identToInt #-} -identToInt :: Ident -> Integer -identToInt (Ident ident) = go 0 1 0 - where - go ix degree res - | ix >= len = res - | otherwise = - let cur = indexByteString ident ix - in go (ix + 1) (identBase * degree) (res + cur * degree) - - len = lengthOfByteString ident - -{-# inlinable assetClassValueContains #-} -assetClassValueContains :: Value -> AssetClass -> Bool -assetClassValueContains v (AssetClass (cs,tk)) = valueContains v cs tk - -{-# inlinable valueContains #-} -valueContains :: Value -> CurrencySymbol -> TokenName -> Bool -valueContains v cs tk = - case Map.lookup cs (getValue v) of - Nothing -> False - Just tks -> case Map.lookup tk tks of - Just n -> n /= 0 - Nothing -> False - --- | Lots of datatypes of ours contain information relating to the assets in a --- pool; `Coin` can act as an index into those datatypes through the `Pairlike` class. -data Coin = CoinA | CoinB - deriving stock (Prelude.Show, Prelude.Eq, Prelude.Ord, Generic) - deriving anyclass (NFData, FromJSON, ToJSON) - deriving anyclass (Random.Finite, Random.Uniform) - -instance Eq Coin where - CoinA == CoinA = True - CoinB == CoinB = True - _ == _ = False - --- e `ofCoin` c $$ c == e -class Pairlike c x e | x -> e, x -> c where - infixl 9 $$ - ($$) :: x -> Coin -> e - infixl 8 `ofCoin` - ofCoin :: c => e -> Coin -> x - -instance Pairlike (AdditiveMonoid a) (AB a) a where - {-# inlinable ($$) #-} - AB a _ $$ CoinA = a - AB _ b $$ CoinB = b - {-# inline conlike ofCoin #-} - a `ofCoin` CoinA = AB a zero - b `ofCoin` CoinB = AB zero b - -{-# inline conlike memo #-} -memo :: (Coin -> a) -> AB a -memo f = AB (f CoinA) (f CoinB) - -data AB a = AB !a !a - deriving stock (Generic, Prelude.Eq, Prelude.Functor, Prelude.Show, Prelude.Ord) - deriving anyclass (NFData, ToJSON, FromJSON) - -instance Eq a => Eq (AB a) where - {-# inlinable (==) #-} - AB a b == AB a' b' = a == a' && b == b' - -instance Functor AB where - {-# inlinable fmap #-} - fmap f (AB a b) = AB (f a) (f b) - -instance Foldable AB where - {-# inlinable foldr #-} - foldr f nil (AB a b) = f a (f b nil) - -instance AdditiveSemigroup a => AdditiveSemigroup (AB a) where - {-# inlinable (+) #-} - AB a b + AB a' b' = AB (a+a') (b+b') - -instance AdditiveGroup a => AdditiveGroup (AB a) where - {-# inlinable (-) #-} - AB a b - AB a' b' = AB (a-a') (b-b') - -instance AdditiveMonoid a => AdditiveMonoid (AB a) where - {-# inline conlike zero #-} - zero = AB zero zero - -data SwapAggregate - = SwapAggregate !Integer !Integer !Integer !Integer - -instance AdditiveSemigroup SwapAggregate where - {-# inlinable (+) #-} - SwapAggregate a b c d + SwapAggregate a' b' c' d' = - let (!a'',!b'',!c'',!d'') = (a+a',b+b',c+c',d+d') - in SwapAggregate a'' b'' c'' d'' - -instance AdditiveMonoid SwapAggregate where - {-# inline conlike zero #-} - zero = SwapAggregate 0 0 0 0 - -data ABL a - = ABL !a !a !a - deriving (Prelude.Show, Prelude.Functor) - deriving stock Generic - deriving anyclass (ToJSON, FromJSON) - -{-# inline conlike liquidity #-} -liquidity :: ABL a -> a -liquidity (ABL _ _ l) = l - -{-# inline conlike ofLiquidity #-} -ofLiquidity :: AdditiveMonoid a => a -> ABL a -ofLiquidity l = ABL zero zero l - -instance Pairlike (AdditiveMonoid a) (ABL a) a where - {-# inlinable ($$) #-} - ABL a _ _ $$ CoinA = a - ABL _ b _ $$ CoinB = b - {-# inlinable ofCoin #-} - a `ofCoin` CoinA = ABL a zero zero - b `ofCoin` CoinB = ABL zero b zero - -{-# inline conlike noLiquidity #-} -noLiquidity :: AB Integer -> ABL Integer -noLiquidity (AB a b) = ABL a b zero - -instance AdditiveSemigroup a => AdditiveSemigroup (ABL a) where - {-# inlinable (+) #-} - ABL a b l + ABL a' b' l' = - ABL (a+a') (b+b') (l+l') - -instance AdditiveGroup a => AdditiveGroup (ABL a) where - {-# inlinable (-) #-} - ABL a b l - ABL a' b' l' = - ABL (a-a') (b-b') (l-l') - -instance AdditiveMonoid a => AdditiveMonoid (ABL a) where - {-# inline conlike zero #-} - zero = ABL zero zero zero - -instance (Eq k, AdditiveSemigroup a) => AdditiveSemigroup (Map k a) where - {-# inlinable (+) #-} - (+) = Map.unionWith (+) - -instance (Eq k, AdditiveGroup a) => AdditiveGroup (Map k a) where - {-# inlinable (-) #-} - (-) = Map.unionWith (-) - -instance (Eq k, AdditiveMonoid a) => AdditiveMonoid (Map k a) where - {-# inline conlike zero #-} - zero = Map.empty - -{-# inlinable unsafeTxInValue #-} -unsafeTxInValue :: _ -> Value -unsafeTxInValue (unsafeDataAsConstr -> (_, [_, (unsafeDataAsConstr -> (_, [_, (unsafeFromBuiltinData -> v), _, _]))])) = v -unsafeTxInValue _ = error () - -{-# inlinable toWeek #-} -toWeek :: POSIXTime -> Week -toWeek (POSIXTime t) = - Week (t `divide` 604_800_000) - -- 1000 (millseconds / second) * 60 (seconds / minute) * 60 (minutes / hour) * 24 (hours / day) * 7 (days / week) - -newtype Week = Week { getWeek :: Integer } - deriving newtype (AdditiveMonoid, AdditiveSemigroup, AdditiveGroup, PlutusTx.UnsafeFromData, PlutusTx.FromData, PlutusTx.ToData) - deriving newtype (ToJSON, FromJSON, NFData) - deriving stock (Prelude.Show, Prelude.Eq, Prelude.Ord) - -PlutusTx.makeLift ''Week -PlutusTx.makeIsDataIndexed ''Coin [('CoinA, 0), ('CoinB, 1)] -PlutusTx.makeIsDataIndexed ''AB [('AB, 0)] - -apCode - :: (PlutusTx.Lift Core.DefaultUni a) - => PlutusTx.CompiledCode (a -> b) - -> a - -> Maybe (PlutusTx.CompiledCode b) -apCode p arg = p `PlutusTx.applyCode` PlutusTx.liftCode (Core.Version 1 0 0) arg - -{-# inlinable onlyHas #-} -onlyHas :: Value -> CurrencySymbol -> TokenName -> (Integer -> Bool) -> Bool -onlyHas v cs tk p - | [(cs', tk', n)] <- flattenValue' v - = cs == cs' && tk == tk' && p n - | otherwise - = False - --- avoid use of unoptimized function findOwnInput - -{-# INLINEABLE scriptInput #-} -scriptInput :: ScriptContext -> TxOut -scriptInput (ScriptContext t_info (Spending o_ref)) = getScriptInput (txInfoInputs t_info) o_ref -scriptInput _ = traceError "script input not found !!!" - -{-# INLINEABLE getScriptInput #-} -getScriptInput :: [TxInInfo] -> TxOutRef -> TxOut -getScriptInput [] _ = traceError "script input not found !!!" -getScriptInput ((TxInInfo tref ot) : tl) o_ref - | tref == o_ref = ot - | otherwise = getScriptInput tl o_ref - -{-# INLINEABLE isScriptAddress #-} -isScriptAddress :: TxOut -> ScriptHash -> Bool -isScriptAddress (TxOut (Address (ScriptCredential h) _) _ _ _) sh = h == sh -isScriptAddress _ _ = False - -{-# INLINEABLE eqAddrCredential #-} -eqAddrCredential :: Address -> Address -> Bool -eqAddrCredential addr1 addr2 = addressCredential addr1 == addressCredential addr2 - -infixl 7 % - -{-# INLINEABLE (%) #-} -(%) :: Integer -> Integer -> Rational -(%) x y = unsafeRatio x y diff --git a/onchain/onchain.cabal b/onchain/onchain.cabal deleted file mode 100644 index 9c99cc5..0000000 --- a/onchain/onchain.cabal +++ /dev/null @@ -1,169 +0,0 @@ -cabal-version: 3.0 - -name: onchain -version: 0.1.0.0 -synopsis: contracts for Sundae swap application -description: Plutus contracts to run Sundae swap application on Cardano blockchain -license-file: ../LICENSE -author: sundae -maintainer: anton@mlabs.gmail edmund@sundaeswap.finance -build-type: Simple -extra-source-files: - factory-boot-settings.json - -flag defer-plugin-errors - description: - Defer errors from plutus GHC plugin to runtime, mainly so we don't get annoying unfolding errors - default: False - manual: True - -common ghc-config - ghc-options: - -Wall -Wno-missing-signatures -Wmissing-exported-signatures - -Wno-partial-type-signatures - -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 - -- TODO: factor out all of these flags into a second common stanza that imports the first common stanza, except for defer plugin errors - -- this way we can make library always have defer-plugin-errors disabled, and we can have a hie.yaml cabal cradle that just uses the other component w/ plugin errors - -- this is kinda a fair bit of stuff to do and I imagine it's fidgety so for now it's probably more than enough to just always defer plugin errors during development - -- to do that just do `cabal configure --flags defer-plugin-errors - if flag(defer-plugin-errors) - ghc-options: - -fplugin-opt PlutusTx.Plugin:defer-errors - - default-language: Haskell2010 - default-extensions: BangPatterns - BlockArguments - ConstraintKinds - DataKinds - DeriveAnyClass - DeriveFoldable - DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable - DerivingStrategies - DerivingVia - ExplicitForAll - FunctionalDependencies - FlexibleContexts - FlexibleInstances - GeneralizedNewtypeDeriving - ImportQualifiedPost - LambdaCase - MonoLocalBinds - MultiParamTypeClasses - NamedFieldPuns - NumericUnderscores - OverloadedStrings - PartialTypeSignatures - PatternGuards - QuasiQuotes - RankNTypes - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TemplateHaskell - TupleSections - TypeApplications - TypeFamilies - TypeOperators - TypeSynonymInstances - ViewPatterns - -library - import: ghc-config - -- Some of these are necessary for plutus to work in GHCi - ghc-options: - -fobject-code - -fno-omit-interface-pragmas - -fno-ignore-interface-pragmas - -fno-specialise - build-depends: base ^>= 4.16 - , aeson - , aeson-pretty - , base16-bytestring - , base-compat - , bytestring - , cardano-crypto-class - , containers - , data-default - , deepseq - , extra - , insert-ordered-containers - , lens - , mtl - , plutus-core - -- , plutus-contract - , plutus-ledger-api - , plutus-tx - , plutus-tx-plugin - , prettyprinter - , pretty-show - , random - , splitmix - , th-compat - , directory - , serialise - , text - , time - , unbounded-delays - , unliftio-core - , yaml - , template-haskell - , ghc-prim - - hs-source-dirs: . - exposed-modules: - Sundae.Compiled - Sundae.Compiled.Factory - Sundae.Compiled.Mints - Sundae.Compiled.Pool - Sundae.Contracts - Sundae.Contracts.Common - Sundae.Contracts.Factory - Sundae.Contracts.Mints - Sundae.Contracts.Pool - Sundae.ShallowData - Sundae.Utilities - default-extensions: NoImplicitPrelude - -test-suite sundae-contracts-tests - import: ghc-config - type: exitcode-stdio-1.0 - ghc-options: -threaded -rtsopts - build-depends: base >=4.9 && <5 - , aeson - , bytestring - , data-default - , file-embed - -- , freer-extras - -- , freer-simple - , lens - , onchain - , mtl - , containers - , cardano-crypto-class - , plutus-core - -- , plutus-contract - , plutus-tx - , plutus-ledger-api - , plutus-tx-plugin - -- , plutus-contract - , prettyprinter - , pretty-show - , record-hasfield - , tasty - , tasty-hunit - , tasty-expected-failure - , tasty-quickcheck - , QuickCheck - , text - , serialise - , time - hs-source-dirs: test - main-is: Main.hs - other-modules: - Test.Contracts.SundaeScooperCompat - Test.Contracts.Orphans - Test.Contracts.Pool - Test.Contracts.Utils diff --git a/onchain/test/Main.hs b/onchain/test/Main.hs deleted file mode 100644 index 23b3e88..0000000 --- a/onchain/test/Main.hs +++ /dev/null @@ -1,12 +0,0 @@ --- | Unit tests -module Main where - -import Test.Tasty -import qualified Test.Contracts.Pool as Pool -import qualified Test.Contracts.SundaeScooperCompat as SundaeScooperCompat - -main :: IO () -main = defaultMain $ testGroup "All Tests" - [ Pool.tests - , SundaeScooperCompat.tests - ] diff --git a/onchain/test/Test/Contracts/Orphans.hs b/onchain/test/Test/Contracts/Orphans.hs deleted file mode 100644 index 69a9ca5..0000000 --- a/onchain/test/Test/Contracts/Orphans.hs +++ /dev/null @@ -1,44 +0,0 @@ -module Test.Contracts.Orphans where - -import Control.Lens -import Data.Coerce -import Data.Maybe - -import PlutusLedgerApi.V2 -import PlutusLedgerApi.V1.Value - -import PlutusTx.AssocMap (Map) - -import qualified PlutusTx.AssocMap as Map -import qualified PlutusTx.Prelude as Plutus - -type instance Index (Map k v) = k -type instance IxValue (Map k v) = v - -instance Plutus.Eq k => Ixed (Map k v) where - ix k f m = case Map.lookup k m of - Just v -> f v <&> \v' -> Map.insert k v' m - Nothing -> pure m - {-# INLINE ix #-} - -instance Plutus.Eq k => At (Map k v) where - at k f m = f mv <&> \r -> case r of - Nothing -> maybe m (const (Map.delete k m)) mv - Just v' -> Map.insert k v' m - where mv = Map.lookup k m - -type instance Index Value = AssetClass -type instance IxValue Value = Integer - -instance Ixed Value where - ix (AssetClass (cs,tk)) f v = - coerce <$> ix cs (ix tk f) (getValue v) - -instance At Value where - at (AssetClass (cs,tk)) f (getValue -> v) = - f mv <&> \r -> case r of - Nothing -> Value $ Map.insert cs (fromMaybe Map.empty (Map.delete tk <$> tks)) v - Just n' -> Value $ Map.insert cs (Map.insert tk n' $ fromMaybe Map.empty tks) v - where - tks = Map.lookup cs v - mv = Map.lookup tk =<< tks diff --git a/onchain/test/Test/Contracts/Pool.hs b/onchain/test/Test/Contracts/Pool.hs deleted file mode 100644 index a19d8d7..0000000 --- a/onchain/test/Test/Contracts/Pool.hs +++ /dev/null @@ -1,719 +0,0 @@ -{-# language TypeApplications #-} -{-# language ViewPatterns #-} -{-# language LambdaCase #-} -{-# language FlexibleContexts #-} - -module Test.Contracts.Pool(tests) where - -import Prelude -import qualified PlutusTx.Prelude as Plutus -import qualified PlutusTx.Ratio as Plutus -import Control.Exception -import Control.Lens -import Test.Tasty -import Test.Tasty.HUnit - -import PlutusLedgerApi.V3 -import PlutusLedgerApi.V1.Value - -import Sundae.Contracts as Sundae -import Sundae.Utilities - -import System.IO.Unsafe - -import Test.Contracts.Orphans -import Test.Contracts.Utils -import PlutusLedgerApi.V1 (Credential(PubKeyCredential)) - -data ScoopTest - = ScoopTest - { poolCoins :: AB AssetClass - , poolCond :: Cond - , escrow1Cond :: Cond - , escrow2Cond :: Cond - , poolMintCond :: Cond - , editMinted :: Value -> Value - , editDisbursed :: [(Address, Value)] -> [(Address, Value)] - , editScooperInputValue :: Value -> Value - , editEscrow1Value :: Value -> Value - , editEscrow1Datum :: EscrowDatum -> EscrowDatum - , editEscrow2Value :: Value -> Value - , editEscrow2Datum :: EscrowDatum -> EscrowDatum - , editOldPoolValue :: Value -> Value - , editPoolOutputValue :: Value -> Value - , editPoolAddress :: Address -> Address - , editMinTakes :: Integer -> Integer - , editValidRange :: Interval POSIXTime -> Interval POSIXTime - , editNewPoolDatum :: PoolDatum -> PoolDatum - , editPoolRedeemer :: PoolRedeemer -> PoolRedeemer - , editEscrowRedeemer :: EscrowRedeemer -> EscrowRedeemer - , editFee :: Value -> Value - } - -defaultValidScoopParams :: ScoopTest -defaultValidScoopParams = - ScoopTest - { poolCoins = AB sundaeCoin swapCoin - , poolCond = Pass - , escrow1Cond = Pass - , escrow2Cond = Pass - , poolMintCond = Pass - , editMinted = id - , editDisbursed = id - , editScooperInputValue = id - , editEscrow1Value = id - , editEscrow1Datum = id - , editEscrow2Value = id - , editEscrow2Datum = id - , editOldPoolValue = id - , editPoolOutputValue = id - , editMinTakes = id - , editValidRange = id - , editNewPoolDatum = id - , editPoolRedeemer = id - , editEscrowRedeemer = id - , editPoolAddress = id - , editFee = id - } - -getIdent :: Ident -> BuiltinByteString -getIdent (Ident i) = i - -mkScoopTest :: ScoopTest -> IO () -mkScoopTest ScoopTest{..} = do - let (AB coin1 coin2) = poolCoins - (poolAmt1, poolAmt2) = (2000, 3000) - initialLiquidityTokenCount = computeInitialLiquidityTokens poolAmt1 poolAmt2 - (depositAmt1, depositAmt2) = (200, 300) - swapAmt = 100 - swapAmtReceived = 142 -- Calculated on repl - extraLiquidity = (depositAmt1 * initialLiquidityTokenCount) `div` poolAmt1 - poolIdent = case intToIdent 0 of { Ident i -> i } - minAda = lovelaceValue 2_000_000 - scooperInputValue = editScooperInputValue $ assetClassValue (scooperTokenAC $ intToIdent 0) 1 - escrow1Value = editEscrow1Value $ (assetClassValue coin1 depositAmt1 <> assetClassValue coin2 depositAmt2 <> minAda <> lovelaceValue testScoopFee) - escrow1Datum = editEscrow1Datum $ EscrowDatum (EscrowAddress user1Dest Nothing) testScoopFee (EscrowDeposit poolIdent (DepositMixed (AB depositAmt1 depositAmt2))) - escrow2Value = editEscrow2Value $ (assetClassValue coin1 swapAmt <> minAda <> lovelaceValue testScoopFee) - escrow2Datum = editEscrow2Datum $ EscrowDatum (EscrowAddress user2Dest Nothing) testScoopFee (EscrowSwap (coin1, swapAmt) (coin2, Just (editMinTakes swapAmtReceived))) - oldPoolValue = editOldPoolValue $ assetClassValue coin1 poolAmt1 <> assetClassValue coin2 poolAmt2 <> assetClassValue (poolAC poolIdent) 1 <> minAda - disbursed = editDisbursed $ [(user1Addr, assetClassValue (liquidityAC poolIdent) extraLiquidity <> minAda), (user2Addr, assetClassValue coin2 swapAmtReceived <> minAda)] - newAmtA = poolAmt1 + depositAmt1 + swapAmt - newAmtB = poolAmt2 + depositAmt2 - swapAmtReceived - newIssued = initialLiquidityTokenCount + extraLiquidity - minted = editMinted $ assetClassValue (liquidityAC poolIdent) (newIssued - initialLiquidityTokenCount) - txFee = editFee (lovelaceValue 1) - scooperFee = 2_500_000 - rewards = max 0 (2 * scooperFee - lovelaceOf txFee) - newPoolValue = editPoolOutputValue $ assetClassValue coin1 newAmtA <> assetClassValue coin2 newAmtB <> assetClassValue (poolAC poolIdent) 1 <> lovelaceValue rewards <> minAda - newPoolDatum = editNewPoolDatum (PoolDatum (AB coin1 coin2) poolIdent newIssued testSwapFees 0 rewards) - newPoolAddr = editPoolAddress poolAddress - poolRedeemer = editPoolRedeemer (PoolScoop scooperUserPkh [0, 1]) - escrowRedeemer = editEscrowRedeemer EscrowScoop - interval = editValidRange (hourInterval (POSIXTime 0)) - factoryValue = assetClassValue factoryAC 1 - runStep $ - [ fromEscrow escrow1Value "Escrow1 script call with scoop" escrow1Cond escrowRedeemer - escrow1Datum - , fromEscrow escrow2Value "Escrow2 script call with scoop" escrow2Cond escrowRedeemer - escrow2Datum - , fromPool oldPoolValue "Pool script call with scoop" poolCond poolRedeemer - (PoolDatum (AB coin1 coin2) poolIdent initialLiquidityTokenCount testSwapFees 0 0) - , referenceFactory factoryValue (toData $ FactoryDatum [scooperUserPkh] [poolStakingCred]) - , toPool newPoolValue newPoolDatum newPoolAddr - , PoolMint minted poolMintCond poolIdent - , CustomInterval interval - , FromUser scooperUserAddr scooperInputValue - , CustomSignatories [scooperUserPkh] - , TxFee txFee - ] ++ (uncurry ToUser <$> disbursed) - where - toPool v d a = ToScript a v (toData d) - fromPool = fromPoolScript poolAddress - fromEscrow = fromEscrowScript escrowAddress - referenceFactory = referenceFactoryScript factoryAddress - -tests :: TestTree -tests = - testGroup "Pool contract" - [ testByCoin "Non-ADA pair" (AB sundaeCoin swapCoin) - , testByCoin "ADA pair" (AB adaCoin sundaeCoin) - ] - -testByCoin :: String -> AB AssetClass -> TestTree -testByCoin title coins@(AB coin1 coin2) = - testGroup title [validTest, invalidTest] - where - validScoopParams = defaultValidScoopParams { poolCoins = coins } - - invalidTest = testGroup "Expecting failure" - [ scoopOutputLacksLiquidity - , scoopIssuedTooMuch - , scoopIssuedNotEnough - , scoopsMintedTooMuch - , scoopsMintedNotEnough - , scoopNotPayingUser - , scoopNotPayingAnyUsers - , scoopJackingUserFunds - , invalidDepositAmount - , invalidSwapAmount - , invalidWithdrawAmount - , slippageFailure - , failedDoubleSwap - , changingCoins - , changingIdent - , changingSwapFees - , unboundedValidRangeDownwards - , unboundedValidRangeBothWays - , mintingPoolToken - , cancelRedeemer - , stolenPoolToken - , noPoolToken - , escrowForDifferentPool - , hugeSwap - , extraPoolAssets - , escrowWithNegativeFee - , stolenPoolToken - , poolChangePayment - , swapTooEarly - , rewardsNotPaidToPool - , poolRewardsFieldNotChanged - , noExtraLockedRewards - , requireSufficientLockedRewards - , marketOrderTakeCoinDoesn'tMatchPool - ] - validTest = testGroup "Expecting success" - [ validScoop - , validScoopWithWithdraw - , validDoubleDeposit - , escrowExtraAda - , escrowExtraSwapCoin - , escrowCancellationKey - , validateSingleDeposit - , validDepositOnDifferentRate - , validDoubleSwap - , validTwoOrdersSamePerson - , poolSetStaking - , poolUnsetStaking - , feeMatchesRewards - , feeExceedsRewards - , marketOrderTakeCoinMatchesPool - ] - -- User 1 is depositing. - -- User 2 is swapping. - testValidScoop = evaluate $ unsafePerformIO $ mkScoopTest validScoopParams - validScoop = testCase "Should pass a valid scoop of deposit + swap" $ testValidScoop - validDoubleDeposit = testCase "Should pass a correct double deposit" $ do - testValidScoop - let (depositAmt1, depositAmt2) = (200, 300) - (poolAmt1, poolAmt2) = (2000, 3000) - initialLiquidityTokenCount = computeInitialLiquidityTokens poolAmt1 poolAmt2 - extraLiquidity = (depositAmt1 * initialLiquidityTokenCount) `div` poolAmt1 - newAmtA = poolAmt1 + depositAmt1*2 - newAmtB = poolAmt2 + depositAmt2*2 - poolIdent = getIdent initialIdent - minAda = lovelaceValue 2_000_000 - txFee = 1 - scooperFee = 2_500_000 - rewards = 2 * scooperFee - txFee - invalid = validScoopParams - { editEscrow2Value = const $ assetClassValue coin1 depositAmt1 <> assetClassValue coin2 depositAmt2 <> minAda <> lovelaceValue testScoopFee - , editEscrow2Datum = const $ EscrowDatum (EscrowAddress user1Dest Nothing) testScoopFee (EscrowDeposit poolIdent (DepositMixed (AB depositAmt1 depositAmt2))) - , editNewPoolDatum = pool'circulatingLP .~ initialLiquidityTokenCount + extraLiquidity*2 - , editMinted = at (liquidityAC poolIdent) .~ Just (extraLiquidity * 2) - , editPoolOutputValue = const $ assetClassValue coin1 newAmtA <> assetClassValue coin2 newAmtB <> assetClassValue (poolAC poolIdent) 1 <> lovelaceValue rewards <> minAda - , editDisbursed = const $ [(user1Addr, assetClassValue (liquidityAC poolIdent) (extraLiquidity*2) <> minAda <> minAda)] -- two orders, two riders - } - mkScoopTest invalid - - validDepositOnDifferentRate = testCase "Should pass a correct double deposit with different rate" $ mkScoopTest $ - let (depositAmt1, depositAmt2) = (100, 100) - (poolAmt1, poolAmt2) = (2000, 3000) - initialLiquidityTokenCount = computeInitialLiquidityTokens poolAmt1 poolAmt2 - -- computed on REPL - userLiq = 324 - change1 = 34 - newAmt1 = 2266 - newAmt2 = 3400 - poolIdent = getIdent initialIdent - minAda = lovelaceValue 2_000_000 - txFee = 1 - scooperFee = 2_500_000 - rewards = 2 * scooperFee - txFee - in validScoopParams - { editEscrow2Value = const $ assetClassValue coin1 depositAmt1 <> assetClassValue coin2 depositAmt2 <> minAda <> lovelaceValue testScoopFee - , editEscrow2Datum = const $ EscrowDatum (EscrowAddress user1Dest Nothing) testScoopFee (EscrowDeposit poolIdent (DepositMixed (AB depositAmt1 depositAmt2))) - , editNewPoolDatum = pool'circulatingLP .~ initialLiquidityTokenCount + userLiq - , editMinted = at (liquidityAC poolIdent) .~ Just userLiq - , editPoolOutputValue = const $ assetClassValue coin1 newAmt1 <> assetClassValue coin2 newAmt2 <> assetClassValue (poolAC poolIdent) 1 <> lovelaceValue rewards <> minAda - , editDisbursed = const $ [(user1Addr, assetClassValue coin1 change1 <> assetClassValue (liquidityAC poolIdent) userLiq <> minAda <> minAda)] -- two orders, two riders - } - - validateSingleDeposit = testCase "Should pass single deposit" $ mkScoopTest $ - let depositAmt1 = 100 - depositAmt2 = 200 - (poolAmt1, poolAmt2) = (2000, 3000) - initialLiquidityTokenCount = computeInitialLiquidityTokens poolAmt1 poolAmt2 - -- computed on REPL - userLiq = 141 - newAmt1 = 2100 - newAmt2 = 3200 - poolIdent = getIdent initialIdent - minAda = lovelaceValue 2_000_000 - txFee = 1 - scooperFee = 2_500_000 - rewards = 2 * scooperFee - txFee - userDeposit1 x = EscrowDatum (EscrowAddress user1Dest Nothing) testScoopFee (EscrowDeposit poolIdent x) - in validScoopParams - { editEscrow1Value = const $ assetClassValue coin1 depositAmt1 <> minAda <> lovelaceValue testScoopFee - , editEscrow1Datum = const $ userDeposit1 (DepositSingle CoinA depositAmt1) - , editEscrow2Value = const $ assetClassValue coin2 depositAmt2 <> minAda <> lovelaceValue testScoopFee - , editEscrow2Datum = const $ userDeposit1 (DepositSingle CoinB depositAmt2) - , editNewPoolDatum = pool'circulatingLP .~ initialLiquidityTokenCount + userLiq - , editMinted = at (liquidityAC poolIdent) .~ Just userLiq - , editPoolOutputValue = const $ assetClassValue coin1 newAmt1 <> assetClassValue coin2 newAmt2 <> assetClassValue (poolAC poolIdent) 1 <> lovelaceValue rewards <> minAda - , editDisbursed = const $ [(user1Addr, assetClassValue (liquidityAC poolIdent) userLiq <> minAda <> minAda)] -- two orders, two riders - } - - validScoopWithWithdraw = testCase "Should pass a valid scoop with deposit + withdraw" $ do - testValidScoop - let (depositAmt1, depositAmt2) = (200, 300) - (poolAmt1, poolAmt2) = (2000, 3000) - initialLiquidityTokenCount = computeInitialLiquidityTokens poolAmt1 poolAmt2 - extraLiquidity = (depositAmt1 * initialLiquidityTokenCount) `div` poolAmt1 - newAmtA = poolAmt1 + depositAmt1 - withdrawReceived1 - newAmtB = poolAmt2 + depositAmt2 - withdrawReceived2 - withdrawAmount = 100 - -- computed on REPL - (withdrawReceived1, withdrawReceived2) = (81, 122) - poolIdent = getIdent initialIdent - minAda = lovelaceValue 2_000_000 - txFee = 1 - scooperFee = 2_500_000 - rewards = 2 * scooperFee - txFee - valid = validScoopParams - { editEscrow2Value = const $ assetClassValue (liquidityAC (getIdent initialIdent)) withdrawAmount <> minAda <> lovelaceValue testScoopFee - , editEscrow2Datum = const $ EscrowDatum (EscrowAddress user2Dest Nothing) testScoopFee (EscrowWithdraw poolIdent withdrawAmount) - , editNewPoolDatum = pool'circulatingLP .~ initialLiquidityTokenCount + extraLiquidity - withdrawAmount - , editMinted = at (liquidityAC (getIdent initialIdent)) .~ Just (extraLiquidity - withdrawAmount) - , editPoolOutputValue = const $ assetClassValue coin1 newAmtA <> assetClassValue coin2 newAmtB <> assetClassValue (poolAC poolIdent) 1 <> lovelaceValue rewards <> minAda - , editDisbursed = const $ [ (user1Addr, assetClassValue (liquidityAC poolIdent) extraLiquidity <> minAda) - , (user2Addr, assetClassValue coin1 withdrawReceived1 <> assetClassValue coin2 withdrawReceived2 <> minAda)] - } - mkScoopTest valid - - -- Pool output < expected liquidity - scoopOutputLacksLiquidity = testCase "Fails when pool output lacks liquidity" $ do - testValidScoop - let invalid = validScoopParams - { editPoolOutputValue = (<> assetClassValue coin2 (-1)) - , poolCond = Fail - } - mkScoopTest invalid - - scoopIssuedNotEnough = testCase "Should fail on issued liquidity < correctly issued liquidity" $ do - testValidScoop - let invalid = validScoopParams - { editNewPoolDatum = pool'circulatingLP -~ 1 - , editMinted = at (liquidityAC (getIdent initialIdent)) . _Just -~ 1 - , poolCond = Fail - } - mkScoopTest invalid - - scoopIssuedTooMuch = testCase "Should fail on issued liquidity > correctly issued liquidity" $ do - testValidScoop - let invalid = validScoopParams - { editNewPoolDatum = pool'circulatingLP +~ 1 - , editMinted = at (liquidityAC (getIdent initialIdent)) . _Just +~ 1 - , poolCond = Fail - } - mkScoopTest invalid - - scoopsMintedNotEnough = testCase "Should fail on minted < delta issued " $ do - testValidScoop - let invalid = validScoopParams - { editMinted = at (liquidityAC (getIdent initialIdent)) . _Just -~ 1 - , poolCond = Fail - } - mkScoopTest invalid - - scoopsMintedTooMuch = testCase "Should fail on minted > delta issued " $ do - testValidScoop - let invalid = validScoopParams - { editMinted = at (liquidityAC (getIdent initialIdent)) . _Just +~ 1 - , poolCond = Fail - } - mkScoopTest invalid - - scoopNotPayingUser = testCase "Should fail on a user not paid out" $ do - testValidScoop - let invalid = validScoopParams - { editDisbursed = tail - , poolCond = Fail - } - mkScoopTest invalid - - scoopNotPayingAnyUsers = testCase "Should fail on all users not paid out" $ do - testValidScoop - let invalid = validScoopParams - { editDisbursed = const [] - , poolCond = Fail - } - mkScoopTest invalid - - scoopJackingUserFunds = testCase "Should fail on a user trying to steal funds" $ do - testValidScoop - let (depositAmt1, depositAmt2) = (200, 300) - (poolAmt1, poolAmt2) = (2000, 3000) - initialLiquidityTokenCount = computeInitialLiquidityTokens poolAmt1 poolAmt2 - extraLiquidity = (depositAmt1 * initialLiquidityTokenCount) `div` poolAmt1 - newAmtA = poolAmt1 + depositAmt1*2 - newAmtB = poolAmt2 + depositAmt2*2 - poolIdent = getIdent initialIdent - minAda = lovelaceValue 2_000_000 - txFee = 1 - scooperFee = 2_500_000 - rewards = 2 * scooperFee - txFee - invalid = validScoopParams - { editEscrow2Value = const $ assetClassValue coin1 depositAmt1 <> assetClassValue coin2 depositAmt2 <> minAda <> lovelaceValue testScoopFee - , editEscrow2Datum = const $ EscrowDatum (EscrowAddress user1Dest Nothing) testScoopFee (EscrowDeposit poolIdent (DepositMixed (AB depositAmt1 depositAmt2))) - , editNewPoolDatum = pool'circulatingLP .~ initialLiquidityTokenCount + extraLiquidity*2 - , editMinted = at (liquidityAC (getIdent initialIdent)) .~ Just (initialLiquidityTokenCount + extraLiquidity*2) - , editPoolOutputValue = const $ assetClassValue coin1 newAmtA <> assetClassValue coin2 newAmtB <> assetClassValue (poolAC poolIdent) 1 <> lovelaceValue rewards <> minAda - , editDisbursed = const $ [(user1Addr, assetClassValue (liquidityAC poolIdent) extraLiquidity <> minAda) - , (user2Addr, assetClassValue (liquidityAC poolIdent) extraLiquidity <> minAda)] - , poolCond = Fail} - mkScoopTest invalid - - invalidDepositAmount = testCase "Should fail on a deposit without the right amount of tokens" $ do - testValidScoop - let invalid = validScoopParams - { editEscrow1Value = (<> assetClassValue coin2 (-199)) - , poolCond = Fail} - mkScoopTest invalid - - invalidSwapAmount = testCase "Should fail on a swap without the right amount of tokens" $ do - testValidScoop - let invalid = validScoopParams - { editEscrow2Value = (<> assetClassValue coin1 (-140)) - , poolCond = Fail} - mkScoopTest invalid - - invalidWithdrawAmount = testCase "Should fail on a withdrawal without the right amount of tokens" $ do - testValidScoop - let (depositAmt1, depositAmt2) = (200, 300) - (poolAmt1, poolAmt2) = (2000, 3000) - initialLiquidityTokenCount = computeInitialLiquidityTokens poolAmt1 poolAmt2 - extraLiquidity = (depositAmt1 * initialLiquidityTokenCount) `div` poolAmt1 - newAmtA = poolAmt1 + depositAmt1 - withdrawReceived1 - newAmtB = poolAmt2 + depositAmt2 - withdrawReceived2 - withdrawAmount = 100 - (withdrawReceived1, withdrawReceived2) = (81, 122) - poolIdent = getIdent initialIdent - minAda = lovelaceValue 2_000_000 - txFee = 1 - scooperFee = 2_500_000 - rewards = 2 * scooperFee - txFee - invalid = validScoopParams - { editEscrow2Value = const $ assetClassValue (liquidityAC (getIdent initialIdent)) (withdrawAmount - 100) <> minAda <> lovelaceValue testScoopFee - , editEscrow2Datum = const $ EscrowDatum (EscrowAddress user2Dest Nothing) testScoopFee (EscrowWithdraw poolIdent (withdrawAmount - 1)) - , editNewPoolDatum = pool'circulatingLP .~ initialLiquidityTokenCount + extraLiquidity - (withdrawAmount - 100) - , editPoolOutputValue = const $ assetClassValue coin1 newAmtA <> assetClassValue coin2 newAmtB <> assetClassValue (poolAC poolIdent) 1 <> lovelaceValue rewards <> minAda - , editDisbursed = const $ [ (user1Addr, assetClassValue (liquidityAC poolIdent) extraLiquidity <> minAda) - , (user2Addr, assetClassValue coin1 withdrawReceived1 <> assetClassValue coin2 withdrawReceived2 <> minAda)] - , poolCond = Fail - } - mkScoopTest invalid - - slippageFailure = testCase "Should fail on a swap where the slippage amt > amt received" $ do - testValidScoop - let invalid = validScoopParams - { editMinTakes = (+ 2) - , poolCond = Fail} - mkScoopTest invalid - - validDoubleSwap = testCase "Should work on a double swap" $ do - let swapAmt = 200 - swapReceived1 = 270 - swapReceived2 = 225 - (poolAmt1, poolAmt2) = (2000, 3000) - initialLiquidityTokenCount = computeInitialLiquidityTokens poolAmt1 poolAmt2 - newAmtA = poolAmt1 + swapAmt*2 - newAmtB = poolAmt2 - swapReceived1 - swapReceived2 - poolIdent = getIdent initialIdent - minAda = lovelaceValue 2_000_000 - txFee = 1 - scooperFee = 2_500_000 - rewards = 2 * scooperFee - txFee - valid = validScoopParams - { editEscrow1Value = const $ assetClassValue coin1 swapAmt <> minAda <> lovelaceValue testScoopFee - , editEscrow1Datum = const $ EscrowDatum (EscrowAddress user1Dest Nothing) testScoopFee (EscrowSwap (coin1, swapAmt) (coin2, Just swapReceived1)) - , editEscrow2Value = const $ assetClassValue coin1 swapAmt <> minAda <> lovelaceValue testScoopFee - , editEscrow2Datum = const $ EscrowDatum (EscrowAddress user2Dest Nothing) testScoopFee (EscrowSwap (coin1, swapAmt) (coin2, Just swapReceived2)) - , editNewPoolDatum = pool'circulatingLP .~ initialLiquidityTokenCount - , editMinted = at (liquidityAC (getIdent initialIdent)) .~ Nothing - , editPoolOutputValue = const $ assetClassValue coin1 newAmtA <> assetClassValue coin2 newAmtB <> assetClassValue (poolAC poolIdent) 1 <> lovelaceValue rewards <> minAda - , editDisbursed = const $ [ (user1Addr, assetClassValue coin2 swapReceived1 <> minAda) - , (user2Addr, assetClassValue coin2 swapReceived2 <> minAda)] - } - mkScoopTest valid - - validTwoOrdersSamePerson = testCase "Should work with two orders from the same user" $ do - let swapAmt = 200 - swapReceived1 = 270 - swapReceived2 = 225 - swapReceivedT = swapReceived1 + swapReceived2 - (poolAmt1, poolAmt2) = (2000, 3000) - initialLiquidityTokenCount = computeInitialLiquidityTokens poolAmt1 poolAmt2 - newAmtA = poolAmt1 + swapAmt*2 - newAmtB = poolAmt2 - swapReceivedT - poolIdent = getIdent initialIdent - minAda = lovelaceValue 2_000_000 - txFee = 1 - scooperFee = 2_500_000 - rewards = 2 * scooperFee - txFee - valid = validScoopParams - { editEscrow1Value = const $ assetClassValue coin1 swapAmt <> minAda <> lovelaceValue testScoopFee - , editEscrow1Datum = const $ EscrowDatum (EscrowAddress user1Dest Nothing) testScoopFee (EscrowSwap (coin1, swapAmt) (coin2, Just swapReceived1)) - , editEscrow2Value = const $ assetClassValue coin1 swapAmt <> minAda <> lovelaceValue testScoopFee - , editEscrow2Datum = const $ EscrowDatum (EscrowAddress user1Dest Nothing) testScoopFee (EscrowSwap (coin1, swapAmt) (coin2, Just swapReceived2)) - , editNewPoolDatum = pool'circulatingLP .~ initialLiquidityTokenCount - , editMinted = at (liquidityAC (getIdent initialIdent)) .~ Nothing - , editPoolOutputValue = const $ assetClassValue coin1 newAmtA <> assetClassValue coin2 newAmtB <> assetClassValue (poolAC poolIdent) 1 <> lovelaceValue rewards <> minAda - , editDisbursed = const $ [ (user1Addr, assetClassValue coin2 swapReceivedT <> minAda <> minAda)] - } - mkScoopTest valid - - escrowExtraAda = testCase "an escrow with extra ada" $ do - mkScoopTest validScoopParams - { editEscrow1Value = at (assetClass adaSymbol adaToken) . _Just +~ 10_000_000 - } - - escrowExtraSwapCoin = testCase "an escrow with extra 'swap coin'" $ do - mkScoopTest validScoopParams - { editEscrow1Value = at swapCoin . _Just +~ 10_000_000 - } - - escrowCancellationKey = testCase "an escrow with an extra cancellation key" $ do - testValidScoop - mkScoopTest validScoopParams - { editEscrow1Datum = escrow'address %~ (\(EscrowAddress dest Nothing) -> EscrowAddress dest (Just user2Pkh)) - } - - failedDoubleSwap = testCase "Should fail on a swap where slippage causes failure" $ do - testValidScoop - let swapAmt = 200 - swapReceived1 = 271 - swapReceived2 = 226 - swapMinTakes = 250 - (poolAmt1, poolAmt2) = (2000, 3000) - initialLiquidityTokenCount = computeInitialLiquidityTokens poolAmt1 poolAmt2 - newAmtA = poolAmt1 + swapAmt*2 - newAmtB = poolAmt2 - swapReceived1 - swapReceived2 - poolIdent = getIdent initialIdent - minAda = lovelaceValue 2_000_000 - txFee = 1 - scooperFee = 2_500_000 - rewards = 2 * scooperFee - txFee - invalid = validScoopParams - { editEscrow1Value = const $ assetClassValue coin1 swapAmt <> minAda - , editEscrow1Datum = const $ EscrowDatum (EscrowAddress user1Dest Nothing) testScoopFee (EscrowSwap (coin1, swapAmt) (coin2, Just swapMinTakes)) - , editEscrow2Value = const $ assetClassValue coin1 swapAmt <> minAda - , editEscrow2Datum = const $ EscrowDatum (EscrowAddress user2Dest Nothing) testScoopFee (EscrowSwap (coin1, swapAmt) (coin2, Just swapMinTakes)) - , editNewPoolDatum = pool'circulatingLP .~ initialLiquidityTokenCount - , editMinted = at (liquidityAC (getIdent initialIdent)) .~ Nothing - , editPoolOutputValue = const $ assetClassValue coin1 newAmtA <> assetClassValue coin2 newAmtB <> assetClassValue (poolAC poolIdent) 1 <> lovelaceValue rewards <> minAda - , editDisbursed = const $ [ (user1Addr, assetClassValue coin2 swapReceived1 <> minAda) - , (user2Addr, assetClassValue coin2 swapReceived2 <> minAda)] - , poolCond = Fail - } - mkScoopTest invalid - - changingCoins = testCase "Should fail when trying to change the datum's coin pair" $ do - testValidScoop - mkScoopTest validScoopParams - { editNewPoolDatum = pool'coins .~ AB (liquidityAC (getIdent (intToIdent 0))) (liquidityAC (getIdent (intToIdent 1))) - , poolCond = Fail - } - - changingIdent = testCase "Should fail when trying to change the pool identifier" $ do - testValidScoop - mkScoopTest validScoopParams - { editNewPoolDatum = pool'poolIdent .~ getIdent (intToIdent 1) - , poolCond = Fail - } - - changingSwapFees = testCase "Should fail when trying to change the swap fees" $ do - testValidScoop - mkScoopTest validScoopParams - { editNewPoolDatum = pool'swapFees .~ SwapFees (Plutus.unsafeRatio 1 2) - , poolCond = Fail - } - - unboundedValidRangeDownwards = testCase "Should fail with a downward-unbounded valid range" $ do - testValidScoop - mkScoopTest validScoopParams - { editValidRange = \i -> Interval (LowerBound NegInf True) (ivTo i) - , poolCond = Fail - } - - unboundedValidRangeBothWays = testCase "Should fail with a totally unbounded valid range" $ do - testValidScoop - mkScoopTest validScoopParams - { editValidRange = const $ Interval (LowerBound NegInf True) (UpperBound PosInf True) - , poolCond = Fail - } - - mintingPoolToken = testCase "attempting to mint a pool token during a scoop" $ do - testValidScoop - mkScoopTest validScoopParams - { editMinted = at (poolAC (getIdent initialIdent)) .~ Just 1 - , poolCond = Fail - } - - cancelRedeemer = testCase "scooping with EscrowCancel as the escrow redeemer" $ do - testValidScoop - mkScoopTest validScoopParams - { editEscrowRedeemer = const EscrowCancel - , escrow1Cond = Fail - , escrow2Cond = Fail - } - - stolenPoolToken = testCase "pool token not in pool output" $ do - testValidScoop - mkScoopTest validScoopParams - { editPoolOutputValue = at (poolAC (getIdent initialIdent)) .~ Nothing - , poolCond = Fail - , escrow1Cond = Fail - , escrow2Cond = Fail - } - - noPoolToken = testCase "pool token nowhere to be seen" $ do - testValidScoop - mkScoopTest validScoopParams - { editPoolOutputValue = at (poolAC (getIdent initialIdent)) .~ Nothing - , editOldPoolValue = at (poolAC (getIdent initialIdent)) .~ Nothing - , escrow1Cond = Fail - , escrow2Cond = Fail - , poolCond = Fail - , poolMintCond = Fail - } - - escrowForDifferentPool = testCase "an escrow for a different pool" $ do - testValidScoop - let (depositAmt1, depositAmt2) = (200, 300) - mkScoopTest validScoopParams - { editEscrow1Datum = const $ - EscrowDatum - (EscrowAddress user1Dest Nothing) - testScoopFee - (EscrowDeposit (getIdent $ intToIdent 1) (DepositMixed (AB depositAmt1 depositAmt2))) - , poolCond = Fail - } - - hugeSwap = testCase "an escrow for a swap way too huge for the pool" $ do - testValidScoop - let hugeSwapAmount = 1_000_000_000_000_000 - mkScoopTest validScoopParams - { editEscrow1Value = at (poolCoins validScoopParams $$ CoinA) .~ Just hugeSwapAmount - , editEscrow1Datum = escrow'action .~ EscrowSwap (coin1, hugeSwapAmount) (coin2, Nothing) - , poolCond = Fail - } - - extraPoolAssets = testCase "the pool has more of its assets" $ do - testValidScoop - mkScoopTest validScoopParams - { editPoolOutputValue = at (poolCoins validScoopParams $$ CoinA) . _Just +~ 1 - , poolCond = Fail - } - - escrowWithNegativeFee = testCase "an escrow with a negative fee" $ do - testValidScoop - mkScoopTest validScoopParams - { editEscrow1Datum = escrow'scoopFee .~ (-testScoopFee) - , poolCond = Fail - } - - poolSetStaking = testCase "change staking key of pool to a non-empty credential" $ do - mkScoopTest validScoopParams - { editPoolAddress = \(Address previousPoolPaymentCred _) -> - Address previousPoolPaymentCred (Just (StakingHash (PubKeyCredential "1234"))) - } - - poolUnsetStaking = testCase "unset staking key of pool" $ do - mkScoopTest validScoopParams - { editPoolAddress = \(Address previousPoolPaymentCred _) -> - Address previousPoolPaymentCred Nothing - } - - poolChangePayment = testCase "change payment key of pool" $ do - mkScoopTest validScoopParams - { editPoolAddress = \(Address _ previousPoolStakingCred) -> - Address (ScriptCredential "0") previousPoolStakingCred - , poolCond = Fail - } - - swapTooEarly = testCase "swapping before marketOpenTime" $ do - testValidScoop - mkScoopTest validScoopParams - { editValidRange = \i -> Interval (LowerBound (Finite (-1)) True) (ivTo i) - , poolCond = Fail - } - - rewardsNotPaidToPool = testCase "rewards not paid to pool" $ do - testValidScoop - let - txFee = 1 - scooperFee = 2_500_000 - rewards = 2 * scooperFee - txFee - mkScoopTest validScoopParams - { editPoolOutputValue = (<> Plutus.inv (lovelaceValue rewards)) - , poolCond = Fail - } - - poolRewardsFieldNotChanged = testCase "pool rewards field not updated correctly" $ do - mkScoopTest validScoopParams - { editNewPoolDatum = pool'rewards .~ 0 - , poolCond = Fail - } - - noExtraLockedRewards = testCase "may not lock extra rewards" $ do - let extra = 10_000 - mkScoopTest validScoopParams - { editNewPoolDatum = pool'rewards +~ extra - , editPoolOutputValue = (<> lovelaceValue extra) - , poolCond = Fail - } - - requireSufficientLockedRewards = testCase "must lock sufficient rewards" $ do - let missing = 10_000 - mkScoopTest validScoopParams - { editNewPoolDatum = pool'rewards -~ missing - , editPoolOutputValue = (<> Plutus.inv (lovelaceValue missing)) - , poolCond = Fail - } - - feeExceedsRewards = testCase "fee exceeds rewards" $ do - mkScoopTest validScoopParams - { editFee = const $ lovelaceValue 5_000_001 - } - - feeMatchesRewards = testCase "fee matches rewards" $ do - mkScoopTest validScoopParams - { editFee = const $ lovelaceValue 5_000_000 - } - - marketOrderTakeCoinMatchesPool = testCase "market order expecting a coin in the pool" $ do - let - swapAmt = 100 - mkScoopTest validScoopParams - { editEscrow2Datum = const $ EscrowDatum (EscrowAddress user2Dest Nothing) testScoopFee (EscrowSwap (coin1, swapAmt) (coin2, Nothing)) - } - - marketOrderTakeCoinDoesn'tMatchPool = testCase "market order expecting a coin not in the pool" $ do - let - coin3 = toCoin "worm" - swapAmt = 100 - mkScoopTest validScoopParams - { editEscrow2Datum = const $ EscrowDatum (EscrowAddress user2Dest Nothing) testScoopFee (EscrowSwap (coin1, swapAmt) (coin3, Nothing)) - , poolCond = Fail - } diff --git a/onchain/test/Test/Contracts/SundaeScooperCompat.hs b/onchain/test/Test/Contracts/SundaeScooperCompat.hs deleted file mode 100644 index b783e43..0000000 --- a/onchain/test/Test/Contracts/SundaeScooperCompat.hs +++ /dev/null @@ -1,43 +0,0 @@ -module Test.Contracts.SundaeScooperCompat - ( tests - ) where - -import Sundae.Utilities -import Sundae.Contracts.Common -import Sundae.Contracts.Pool - -import PlutusLedgerApi.V3 -import PlutusLedgerApi.V1.Value - -import Test.Tasty -import Test.Tasty.HUnit - --- This test mirrors the sundae-scooper test here: --- https://github.com/SundaeSwap-finance/sundae-scooper/blob/beca2e3de965bde25189262ff3e6866b1abffb26/cpp/cpp_test.go#L98-L107 -tests :: TestTree -tests = testCase "sundae-scooper compat tests" $ do - let pkh = "00000000000000000000000000000000" - let escrows = - [ ( EscrowDestination (Address (PubKeyCredential (PubKeyHash pkh)) Nothing) Nothing - , EscrowDeposit "00" (DepositMixed (AB 105 200)) - ) - ] - let poolA = 1000000 - let poolB = 2000000 - let isqrt = floor . sqrt @Double . fromIntegral - let initialLiquidity = isqrt (poolA * poolB) - let coinA = AssetClass ("", "") - let coinB = AssetClass ("", "") - let (ScoopResult _cons _a _b newLiquidity) = - doEscrows - "00" - coinA - coinB - (SwapFees (1 % 2000)) - (ABL poolA poolB initialLiquidity) - escrows - putStr "liquidity before scoop:" - print initialLiquidity - putStr "liquidity after scoop:" - print newLiquidity - (newLiquidity - initialLiquidity) @?= 141 diff --git a/onchain/test/Test/Contracts/Utils.hs b/onchain/test/Test/Contracts/Utils.hs deleted file mode 100644 index 086fe44..0000000 --- a/onchain/test/Test/Contracts/Utils.hs +++ /dev/null @@ -1,359 +0,0 @@ -{-# language TypeApplications #-} -{-# language ViewPatterns #-} -{-# language LambdaCase #-} -{-# language FlexibleContexts #-} -{-# language GADTs #-} - -module Test.Contracts.Utils where - -import Codec.Serialise hiding (decode, Fail) -import Control.Exception -import Control.Lens hiding (ix) -import Data.ByteString(ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Short as SBS -import Data.ByteString.Hash qualified as Hash -import Data.Coerce (Coercible, coerce) -import Data.Containers.ListUtils (nubOrdOn) -import Data.FileEmbed (embedFile, makeRelativeToProject) -import Data.Maybe (catMaybes) -import Data.String(fromString) -import PlutusLedgerApi.V3 -import PlutusLedgerApi.V1.Value -import qualified PlutusTx.Ratio as Ratio -import qualified PlutusTx.Prelude as Plutus -import qualified PlutusTx.AssocMap as AssocMap - -import qualified Cardano.Crypto.Hash.Class as Crypto - -import Test.Tasty.HUnit -import Sundae.Contracts as Sundae -import Sundae.Utilities as Sundae -import qualified Sundae.Compiled as Sundae -import qualified Sundae.ShallowData as SD -import qualified Data.Aeson as Aeson -import System.IO.Unsafe (unsafePerformIO) - -data Step - = FromUser Address Value - | FromScript Address Value String Cond ScriptInput - | ToUser Address Value - | ToScript Address Value Data - | ReferenceInput Address Value Data - | PoolMint Value Cond BuiltinByteString - | FactoryBootMint Value Cond FactoryBootMintRedeemer - | CustomInterval (Interval POSIXTime) - | CustomSignatories [PubKeyHash] - | TxFee Value - -data Cond = Pass | Fail -data ScriptInput - = PoolScriptInput PoolRedeemer PoolDatum - | EscrowScriptInput EscrowRedeemer EscrowDatum - | FactoryScriptInput FactoryRedeemer FactoryDatum - -fromPoolScript :: Address -> Value -> String -> Cond -> PoolRedeemer -> PoolDatum -> Step -fromPoolScript a v dbg cond red dat = FromScript a v dbg cond (PoolScriptInput red dat) -fromEscrowScript :: Address -> Value -> String -> Cond -> EscrowRedeemer -> EscrowDatum -> Step -fromEscrowScript a v dbg cond red dat = FromScript a v dbg cond (EscrowScriptInput red dat) -fromFactoryScript :: Address -> Value -> String -> Cond -> FactoryRedeemer -> FactoryDatum -> Step -fromFactoryScript a v dbg cond red dat = FromScript a v dbg cond (FactoryScriptInput red dat) -referenceFactoryScript :: Address -> Value -> Data -> Step -referenceFactoryScript a v d = ReferenceInput a v d - -tiInputs :: Lens' TxInfo [TxInInfo] -tiInputs f info = - (\i' -> info{txInfoInputs = i'}) <$> f (txInfoInputs info) - -tiOutputs :: Lens' TxInfo [TxOut] -tiOutputs f info = - (\i' -> info{txInfoOutputs = i'}) <$> f (txInfoOutputs info) - -tiReferenceInputs :: Lens' TxInfo [TxInInfo] -tiReferenceInputs f info = - (\i' -> info{txInfoReferenceInputs = i'}) <$> f (txInfoReferenceInputs info) - -tiMint :: Lens' TxInfo Value -tiMint f info = - (\i' -> info{txInfoMint = i'}) <$> f (txInfoMint info) - -tiData :: Lens' TxInfo (Map DatumHash Datum) -tiData f info = - (\i' -> info{txInfoData = i'}) <$> f (txInfoData info) - -tiValidRange :: Lens' TxInfo (Interval POSIXTime) -tiValidRange f info = - (\i' -> info{txInfoValidRange = i'}) <$> f (txInfoValidRange info) - -tiSignatories :: Lens' TxInfo [PubKeyHash] -tiSignatories f info = - (\i' -> info{txInfoSignatories = i'}) <$> f (txInfoSignatories info) - -tiFee :: Lens' TxInfo Value -tiFee f info = - (\i' -> info{txInfoFee = i'}) <$> f (txInfoFee info) - -user1, user2, scooperUsr :: BuiltinByteString -user1 = "usr#1" -user2 = "usr#2" -scooperUsr = "usr#scooper" - -user1Pkh, user2Pkh, scooperUserPkh :: PubKeyHash -user1Pkh = mkUsrPkh user1 -user2Pkh = mkUsrPkh user2 -scooperUserPkh = mkUsrPkh scooperUsr - -poolStakingCred :: StakingCredential -poolStakingCred = StakingHash (PubKeyCredential "1234") - -user1Addr, user2Addr, scooperUserAddr :: Address -user1Addr = mkUserAddr user1 -user2Addr = mkUserAddr user2 -scooperUserAddr = mkUserAddr scooperUsr - -user1Dest, user2Dest, scooperUserDest :: EscrowDestination -user1Dest = EscrowDestination user1Addr Nothing -user2Dest = EscrowDestination user2Addr Nothing -scooperUserDest = EscrowDestination scooperUserAddr Nothing - -sundaeCoin, swapCoin, adaCoin :: AssetClass -sundaeCoin = toCoin "SUNDAE" -swapCoin = toCoin "Swap" -adaCoin = assetClass adaSymbol adaToken - -currencySymbolOf :: SerialisedScript -> CurrencySymbol -currencySymbolOf script = coerce $ ScriptHash (toBuiltin (hashScript script)) - --- Reference for the implementation of script hashing: --- https://github.com/input-output-hk/cardano-ledger/blob/d421556ef91362d13963a68a94c6f9e752d67e59/eras/babbage/impl/src/Cardano/Ledger/Babbage/Scripts.hs#L35-L42 --- https://github.com/input-output-hk/cardano-ledger/blob/d421556ef91362d13963a68a94c6f9e752d67e59/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs#L449-L456 -hashScript :: SerialisedScript -> BS.ByteString -hashScript script = - let - -- Our scripts are plutus V3 - babbageV3ScriptPrefixTag = "\x03" - in - Hash.blake2b_256 (babbageV3ScriptPrefixTag <> SBS.fromShort script) - -toDatum :: ToData a => a -> Datum -toDatum = Datum . BuiltinData . toData - -vsh :: Coercible ScriptHash a => SerialisedScript -> a -vsh script = coerce $ ScriptHash (toBuiltin (hashScript script)) - -factoryBootSettingsFile :: ByteString -factoryBootSettingsFile = $(makeRelativeToProject "test/data/factory-boot-settings.json" >>= embedFile) - -testFactoryBootSettings :: FactoryBootSettings -testFactoryBootSettings = - case Aeson.eitherDecodeStrict' factoryBootSettingsFile of - Left bad -> error ("Could not load factory boot settings: " ++ bad) - Right b -> b - -testTreasuryBootSettings :: TreasuryBootSettings -testTreasuryBootSettings = TreasuryBootSettings $ ProtocolBootUTXO $ - TxOutRef (mkTxId "treasuryBoot") 1 - -testSwapFees :: SwapFees -testSwapFees = SwapFees (Ratio.fromGHC 0.01) - -testScoopFee :: Integer -testScoopFee = 2_500_000 - -testFactory :: SerialisedScript -testFactory = - Sundae.factoryScript factoryBootCS - -testPoolMint :: SerialisedScript -testPoolMint = - Sundae.poolMintingScript (coerce $ currencySymbolOf factoryBootMint) (OldPoolCurrencySymbol $ CurrencySymbol "") - -testPool :: SerialisedScript -testPool = - Sundae.poolScript factoryBootCS poolCS escrowHash - -testEscrow :: SerialisedScript -testEscrow = - Sundae.escrowScript poolCS - -factoryBootMint :: SerialisedScript -factoryBootMint = - Sundae.factoryBootMintingScript testFactoryBootSettings - -factoryBootCS :: FactoryBootCurrencySymbol -factoryBootCS = - FactoryBootCurrencySymbol $ currencySymbolOf factoryBootMint - -poolCS :: PoolCurrencySymbol -poolCS = - PoolCurrencySymbol $ currencySymbolOf testPoolMint - -poolSH :: PoolScriptHash -poolSH = vsh testPool - -toCoin :: ByteString -> AssetClass -toCoin str = AssetClass (currencySymbol str, tokenName str) - -factoryAC :: AssetClass -factoryAC = - AssetClass (coerce factoryBootCS, factoryToken) - -liquidityAC :: BuiltinByteString -> AssetClass -liquidityAC poolIdent = - AssetClass (coerce poolCS, computeLiquidityTokenName poolIdent) - -poolAC :: BuiltinByteString -> AssetClass -poolAC poolIdent = - AssetClass (coerce poolCS, computePoolTokenName poolIdent) - -scooperTokenAC :: Ident -> AssetClass -scooperTokenAC week = - AssetClass (coerce factoryBootCS, computeScooperTokenName week) - -poolHash :: PoolScriptHash -poolHash = vsh testPool - -escrowHash :: EscrowScriptHash -escrowHash = vsh testEscrow - -poolAddress :: Address -poolAddress = scriptHashToAddress $ vsh testPool - -escrowAddress :: Address -escrowAddress = scriptHashToAddress $ vsh testEscrow - -factoryAddress :: Address -factoryAddress = scriptHashToAddress $ vsh testFactory - -scriptHashToAddress :: BuiltinByteString -> Address -scriptHashToAddress bs = Address (ScriptCredential (ScriptHash bs)) Nothing - -mkTxId :: BuiltinByteString -> TxId -mkTxId = TxId . Plutus.sha2_256 - -mkUserAddr :: BuiltinByteString -> Address -mkUserAddr = flip Address Nothing . PubKeyCredential . mkUsrPkh - -mkUsrPkh :: BuiltinByteString -> PubKeyHash -mkUsrPkh = PubKeyHash . Plutus.sha2_256 - -mkUserInput :: BuiltinByteString -> Address -> Value -> TxInInfo -mkUserInput txName usr value = - TxInInfo - (TxOutRef (mkTxId txName) 1) - (TxOut usr value NoOutputDatum Nothing) - -mkScriptInput :: BuiltinByteString -> Address -> Value -> DatumHash -> TxInInfo -mkScriptInput txName scriptAddr value datumHash = - TxInInfo - (TxOutRef (mkTxId txName) 1) - (TxOut scriptAddr value (OutputDatumHash datumHash) Nothing) - -mkReferenceInput :: BuiltinByteString -> Address -> Value -> DatumHash -> TxInInfo -mkReferenceInput txName addr value datumHash = - TxInInfo - (TxOutRef (mkTxId txName) 1) - (TxOut addr value (OutputDatumHash datumHash) Nothing) - -lovelaceValue :: Integer -> Value -lovelaceValue = singleton adaSymbol adaToken - -lovelaceValueOf :: Value -> Integer -lovelaceValueOf v = valueOf v adaSymbol adaToken - -onlyLovelace :: Value -> Value -onlyLovelace = lovelaceValue . lovelaceValueOf - --- POSIXTime is milliseconds, so 1 hour is represented as 1000 * 60 * 60 ms -hourInterval :: POSIXTime -> Interval POSIXTime -hourInterval t = - Interval (LowerBound (Finite t) True) (UpperBound (Finite (t + POSIXTime (1000*60*60))) True) - --- Todo: maybe `run` wants to pass in the redeemer as well. -runStep :: [Step] -> Assertion -runStep steps = do - let info = foldr step baseTxInfo (zip [(0::Integer)..] steps) - sequence_ $ catMaybes $ fmap (exec info) $ zip [0..] steps - where - run (EscrowScriptInput redeemer datum) ctx = runEscrow datum redeemer ctx - run (PoolScriptInput redeemer datum) ctx = runPool datum redeemer ctx - run (FactoryScriptInput redeemer datum) ctx = runFactory datum redeemer ctx - runPool datum redeemer ctx = - poolContract factoryBootCS poolCS escrowHash datum redeemer ctx - runEscrow datum redeemer ctx = - escrowContract poolCS datum redeemer ctx - runFactoryBootMint redeemer ctx = - factoryBootMintingContract testFactoryBootSettings redeemer ctx - runPoolMint redeemer ctx = - poolMintingContract factoryBootCS (OldPoolCurrencySymbol $ CurrencySymbol "") poolCS poolSH redeemer ctx - runFactory = - factoryContract factoryBootCS - handleErrors = handle (\(_ :: SomeException) -> pure False) . evaluate - runCond = \case - Pass -> id - Fail -> not - exec :: TxInfo -> (Integer, Step) -> Maybe Assertion - exec info (ix, FromScript _ _ dbg cond scriptInput') = do - let txId = mkTxId (fromString ("#" <> show ix)) - pure $ do - wentThrough <- handleErrors $ run scriptInput' (ScriptContext info (Spending $ TxOutRef txId 1)) - let passes = runCond cond wentThrough - passes @? dbg - exec info (_, PoolMint _ cond ident) = do - pure $ do - wentThrough <- handleErrors $ runPoolMint (MintLP ident) (ScriptContext info (Minting $ coerce poolCS)) `seq` True - let passes = runCond cond wentThrough - passes @? "pool mint failure" - exec info (_, FactoryBootMint _ cond redeemer) = do - pure $ do - wentThrough <- handleErrors $ runFactoryBootMint redeemer (ScriptContext info (Minting $ coerce factoryBootCS)) - let passes = runCond cond wentThrough - passes @? "factory boot mint failure" - exec _ _ = Nothing - mkDatumHash :: ToData a => a -> DatumHash - mkDatumHash x = DatumHash (toBuiltin (Hash.blake2b_256 (LBS.toStrict (serialise (toData x))))) - scriptInputData = \case - EscrowScriptInput _ d -> (mkDatumHash d, toDatum d) - PoolScriptInput _ d -> (mkDatumHash d, toDatum d) - FactoryScriptInput _ d -> (mkDatumHash d, toDatum d) - baseTxInfo = - TxInfo - { txInfoInputs = [] - , txInfoOutputs = [] - , txInfoReferenceInputs = [] - , txInfoFee = lovelaceValue 1 - , txInfoMint = mempty - , txInfoDCert = [] - , txInfoWdrl = fromList [] - , txInfoValidRange = always - , txInfoSignatories = [] - , txInfoRedeemers = fromList [] - , txInfoData = fromList [] - , txInfoId = mkTxId "#testOut"} - step (ix, c) info = - let txIx = fromString ("#" <> show ix) - in case c of - FromScript addr v _ _ (scriptInputData -> (hash, d)) -> - info & tiInputs %~ (mkScriptInput txIx addr v (hash):) - & tiData %~ AssocMap.insert hash d - FromUser addr v -> - info & tiInputs %~ (mkUserInput txIx addr v:) - ToUser addr v -> - info & tiOutputs %~ (TxOut addr v NoOutputDatum Nothing:) - ToScript addr v (BuiltinData -> d) -> - info & tiOutputs %~ (TxOut addr v (OutputDatumHash $ mkDatumHash d) Nothing:) - & tiData %~ AssocMap.insert (mkDatumHash d) (toDatum d) - ReferenceInput addr v (BuiltinData -> d) -> - info & tiReferenceInputs %~ (mkReferenceInput txIx addr v (mkDatumHash d):) - & tiData %~ AssocMap.insert (mkDatumHash d) (toDatum d) - PoolMint v _ _-> - info & tiMint %~ (<> v) - FactoryBootMint v _ _ -> - info & tiMint %~ (<> v) - CustomInterval v -> - info & tiValidRange .~ v - CustomSignatories v -> - info & tiSignatories %~ (++ v) - TxFee f -> - info & tiFee .~ f diff --git a/onchain/test/data/factory-boot-settings.json b/onchain/test/data/factory-boot-settings.json deleted file mode 100644 index 6d1ed3d..0000000 --- a/onchain/test/data/factory-boot-settings.json +++ /dev/null @@ -1,10 +0,0 @@ -{ - "scoopers": [ - "9d1cbb54faf284f5d262f591b1f9201a1858de155157dad49f3881c4", - "694bc6017f9d74a5d9b3ef377b42b9fe4967a04fb1844959057f35bb" - ], - "protocolBootUTXO": { - "txix": 2, - "txid": "213c3838a997b9e1a48334097acb6257099bb8001593c22d583afca429cd5bbf" - } -} diff --git a/aiken/validators/order.ak b/validators/order.ak similarity index 100% rename from aiken/validators/order.ak rename to validators/order.ak diff --git a/aiken/validators/pool.ak b/validators/pool.ak similarity index 100% rename from aiken/validators/pool.ak rename to validators/pool.ak diff --git a/aiken/validators/pool_stake.ak b/validators/pool_stake.ak similarity index 100% rename from aiken/validators/pool_stake.ak rename to validators/pool_stake.ak diff --git a/aiken/validators/settings.ak b/validators/settings.ak similarity index 100% rename from aiken/validators/settings.ak rename to validators/settings.ak diff --git a/aiken/validators/stake.ak b/validators/stake.ak similarity index 100% rename from aiken/validators/stake.ak rename to validators/stake.ak From f6a5b2d4a27bedeace3b2fd5f0de9c517ef315fd Mon Sep 17 00:00:00 2001 From: card Date: Mon, 4 Dec 2023 17:24:09 -0500 Subject: [PATCH 2/3] bump CI Co-authored-by: rrruko --- .github/workflows/tests.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/tests.yml b/.github/workflows/tests.yml index bccfa81..f4c35aa 100644 --- a/.github/workflows/tests.yml +++ b/.github/workflows/tests.yml @@ -13,7 +13,7 @@ jobs: - uses: aiken-lang/setup-aiken@v0.1.0 with: - version: v1.0.7-alpha + version: v1.0.20-alpha - run: aiken fmt --check - run: aiken check From 6e38179d03c67c5355b147b3052750c1a21ac243 Mon Sep 17 00:00:00 2001 From: card Date: Mon, 4 Dec 2023 17:29:44 -0500 Subject: [PATCH 3/3] remove formatter from CI script; we just want the check linter Co-authored-by: rrruko --- .github/workflows/tests.yml | 1 - 1 file changed, 1 deletion(-) diff --git a/.github/workflows/tests.yml b/.github/workflows/tests.yml index f4c35aa..cc04b6d 100644 --- a/.github/workflows/tests.yml +++ b/.github/workflows/tests.yml @@ -15,6 +15,5 @@ jobs: with: version: v1.0.20-alpha - - run: aiken fmt --check - run: aiken check - run: aiken build