├── .dockerignore ├── .github ├── CODEOWNERS ├── ISSUE_TEMPLATE │ ├── -bug---short-description-of-the-problem.md │ ├── -docs--short-description-of-the-documentation-issue.md │ └── -feature--short-description-of-the-feature.md ├── pull_request_template.md └── workflows │ ├── build.yml │ ├── haskell.yml │ └── release.yml ├── .gitignore ├── .gitmodules ├── .pre-commit-config.yaml ├── CONTRIBUTING.md ├── Dockerfile ├── Makefile ├── README.md ├── SECURITY.md ├── cabal.project ├── docker-compose-kupo.yml ├── docker-compose.yml ├── fourmolu.yaml ├── geniusyield-dex-api ├── CHANGELOG.md ├── LICENSE ├── README.md ├── geniusyield-dex-api.cabal └── src │ └── GeniusYield │ ├── Api │ └── Dex │ │ ├── Constants.hs │ │ ├── PartialOrder.hs │ │ ├── PartialOrderConfig.hs │ │ └── Types.hs │ ├── Scripts.hs │ └── Scripts │ ├── Common.hs │ ├── Dex.hs │ └── Dex │ ├── Data.hs │ ├── Nft.hs │ ├── PartialOrder.hs │ ├── PartialOrderConfig.hs │ ├── PartialOrderConfig │ └── Internal.hs │ ├── PartialOrderNft.hs │ └── Version.hs ├── geniusyield-onchain ├── LICENSE ├── README.md ├── app │ └── Main.hs ├── cabal.project ├── fixtures │ ├── nftpolicy-aggressive.txt │ ├── nftpolicy-optimized.txt │ ├── nftpolicy-original.txt │ ├── partialorder-aggressive.txt │ ├── partialorder-optimized.txt │ ├── partialorder-original.txt │ ├── partialorderconfig-aggressive.txt │ ├── partialorderconfig-optimized.txt │ ├── partialorderconfig-original.txt │ ├── partialordernftpolicy-aggressive.txt │ ├── partialordernftpolicy-optimized.txt │ ├── partialordernftpolicy-original.txt │ ├── partialordernftpolicyV1_1-aggressive.txt │ ├── partialordernftpolicyV1_1-optimized.txt │ └── partialordernftpolicyV1_1-original.txt ├── flake.lock ├── flake.nix ├── geniusyield-common │ ├── LICENSE │ ├── data │ │ └── compiled-scripts │ │ │ ├── DEX.NFT │ │ │ ├── DEX.PartialOrder │ │ │ ├── DEX.PartialOrderConfig │ │ │ ├── DEX.PartialOrderConfigTracing │ │ │ ├── DEX.PartialOrderNFT │ │ │ ├── DEX.PartialOrderNFTTracing │ │ │ ├── DEX.PartialOrderNFTV1_1 │ │ │ ├── DEX.PartialOrderNFTV1_1Tracing │ │ │ └── DEX.PartialOrderTracing │ ├── geniusyield-common.cabal │ └── src │ │ └── GeniusYield │ │ └── OnChain │ │ └── Common │ │ ├── Scripts.hs │ │ └── Scripts │ │ └── DEX │ │ └── Data.hs ├── geniusyield-onchain.cabal ├── src │ └── GeniusYield │ │ ├── OnChain │ │ ├── DEX │ │ │ ├── Anastasia_Labs____Genius_Yield_Audit.pdf │ │ │ ├── NFT.hs │ │ │ ├── NFT │ │ │ │ └── Compiled.hs │ │ │ ├── PartialOrder.hs │ │ │ ├── PartialOrder │ │ │ │ ├── Compiled.hs │ │ │ │ └── Types.hs │ │ │ ├── PartialOrderConfig.hs │ │ │ ├── PartialOrderConfig │ │ │ │ └── Compiled.hs │ │ │ ├── PartialOrderNFT.hs │ │ │ ├── PartialOrderNFT │ │ │ │ └── Compiled.hs │ │ │ ├── PartialOrderNFTV1_1.hs │ │ │ ├── PartialOrderNFTV1_1 │ │ │ │ └── Compiled.hs │ │ │ ├── README.md │ │ │ └── Utils.hs │ │ ├── Plutarch │ │ │ ├── Api.hs │ │ │ ├── Crypto.hs │ │ │ ├── Run.hs │ │ │ ├── Time.hs │ │ │ ├── Tx.hs │ │ │ ├── Types.hs │ │ │ ├── Utils.hs │ │ │ └── Value.hs │ │ └── Utils.hs │ │ └── Plutonomy.hs └── tests │ └── geniusyield-onchain-tests.hs ├── geniusyield-orderbot-lib ├── CHANGELOG.md ├── LICENSE ├── README.md ├── geniusyield-orderbot-lib.cabal └── src │ └── GeniusYield │ └── OrderBot │ ├── Adapter │ └── Maestro.hs │ └── Domain │ ├── Assets.hs │ └── Markets.hs ├── geniusyield-server-lib ├── CHANGELOG.md ├── LICENSE ├── README.md ├── app │ └── Main.hs ├── geniusyield-server-lib.cabal └── src │ └── GeniusYield │ └── Server │ ├── Api.hs │ ├── Assets.hs │ ├── Auth.hs │ ├── Config.hs │ ├── Constants.hs │ ├── Ctx.hs │ ├── Dex │ ├── HistoricalPrices │ │ ├── Maestro.hs │ │ ├── TapTools.hs │ │ └── TapTools │ │ │ └── Client.hs │ ├── Markets.hs │ └── PartialOrder.hs │ ├── ErrorMiddleware.hs │ ├── Options.hs │ ├── Orphans.hs │ ├── RequestLoggerMiddleware.hs │ ├── Run.hs │ ├── Tx.hs │ └── Utils.hs ├── no-commit-to-main.sh ├── start.sh └── web └── openapi └── api.yaml /.dockerignore: -------------------------------------------------------------------------------- 1 | Dockerfile 2 | secrets 3 | secrets/* 4 | dist-newstyle 5 | .* 6 | !.git 7 | -------------------------------------------------------------------------------- /.github/CODEOWNERS: -------------------------------------------------------------------------------- 1 | * @geniusyield/dex-contract-api-team 2 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/-bug---short-description-of-the-problem.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: "[BUG]: Short description of the problem" 3 | about: Create a report to help us improve 4 | title: '' 5 | labels: '' 6 | assignees: '' 7 | 8 | --- 9 | 10 | **Describe the bug** 11 | A clear and concise description of what the bug is. 12 | 13 | **To Reproduce** 14 | Steps to reproduce the behavior: 15 | 1. Go to '...' 16 | 2. Click on '....' 17 | 3. Scroll down to '....' 18 | 4. See error 19 | 20 | **Expected behavior** 21 | A clear and concise description of what you expected to happen. 22 | 23 | **Screenshots** 24 | If applicable, add screenshots to help explain your problem. 25 | 26 | **Station (please complete the following information):** 27 | - OS: [e.g. Windows, Ubuntu] 28 | - Version [e.g. 10, 11, 22.02] 29 | 30 | **Additional context** 31 | Add any other context about the problem here. 32 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/-docs--short-description-of-the-documentation-issue.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: "[DOCS] Short description of the documentation issue" 3 | about: Suggest documentation improvements 4 | title: '' 5 | labels: '' 6 | assignees: '' 7 | 8 | --- 9 | 10 | **Describe the issue with the documentation** 11 | A clear and concise description of what the issue is. 12 | 13 | **Suggest a solution** 14 | Describe how the documentation can be improved or corrected. 15 | 16 | **Additional context** 17 | Add any other context, references, or screenshots that might help clarify the issue. 18 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/-feature--short-description-of-the-feature.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: "[FEATURE] Short description of the feature" 3 | about: Suggest an idea for this project 4 | title: '' 5 | labels: '' 6 | assignees: '' 7 | 8 | --- 9 | 10 | **Is your feature request related to a problem? Please describe.** 11 | A clear and concise description of what the problem is. Ex. I'm always frustrated when [...] 12 | 13 | **Describe the solution you'd like** 14 | A clear and concise description of what you want to happen. 15 | 16 | **Describe alternatives you've considered** 17 | A clear and concise description of any alternative solutions or features you've considered. 18 | 19 | **Additional context** 20 | Add any other context or screenshots about the feature request here. 21 | -------------------------------------------------------------------------------- /.github/pull_request_template.md: -------------------------------------------------------------------------------- 1 | Thank you for contributing to `dex-contracts-api` repository! We appreciate your effort and dedication to improving this project. To ensure that your contribution is in line with the project's guidelines and can be reviewed efficiently, please fill out the template below. 2 | 3 | Remember to follow our [Contributing Guide](CONTRIBUTING.md) before submitting your pull request. 4 | 5 | ## Summary 6 | 7 | Please provide a brief, concise summary of the changes in your pull request. Explain the problem you are trying to solve and the solution you have implemented. 8 | 9 | ## Type of Change 10 | 11 | Please mark the relevant option(s) for your pull request: 12 | 13 | - [ ] Bug fix (non-breaking change which fixes an issue) 14 | - [ ] New feature (non-breaking change which adds functionality) 15 | - [ ] Breaking change (fix or feature that would cause existing functionality to not work as expected) 16 | - [ ] Code refactoring (improving code quality without changing its behavior) 17 | - [ ] Documentation update (adding or updating documentation related to the project) 18 | 19 | ## Checklist 20 | 21 | Please ensure that your pull request meets the following criteria: 22 | 23 | - [ ] I have read the [Contributing Guide](CONTRIBUTING.md) 24 | - [ ] My code follows the project's coding style and best practices 25 | - [ ] My code is appropriately commented and includes relevant documentation 26 | - [ ] I have added tests to cover my changes 27 | - [ ] All new and existing tests pass 28 | - [ ] I have updated the documentation, if necessary 29 | 30 | ## Testing 31 | 32 | Please describe the tests you have added or modified, and provide any additional context or instructions needed to run the tests. 33 | 34 | - [ ] Test A 35 | - [ ] Test B 36 | 37 | ## Additional Information 38 | 39 | If you have any additional information or context to provide, such as screenshots, relevant issues, or other details, please include them here. 40 | 41 | -------------------------------------------------------------------------------- /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | name: Validate 2 | 3 | on: 4 | schedule: 5 | - cron: '0 0 * * *' # Runs every day at midnight UTC 6 | 7 | push: 8 | branches: [ "main" ] 9 | pull_request: {} # run for all pull requests targeting any branch 10 | 11 | permissions: 12 | contents: read 13 | pages: write 14 | id-token: write 15 | 16 | concurrency: 17 | group: "pages" 18 | cancel-in-progress: false 19 | 20 | jobs: 21 | validate: 22 | uses: ./.github/workflows/haskell.yml 23 | secrets: inherit 24 | docker: 25 | runs-on: ubuntu-latest 26 | permissions: 27 | packages: write 28 | contents: read 29 | steps: 30 | - name: Checkout 31 | uses: actions/checkout@v4 32 | - name: Set up Docker Buildx 33 | uses: docker/setup-buildx-action@v3 34 | - name: Login to GitHub Container Registry 35 | uses: docker/login-action@v3 36 | with: 37 | registry: ghcr.io 38 | username: ${{ github.actor }} 39 | password: ${{ secrets.GITHUB_TOKEN }} 40 | - id: docker-metadata 41 | uses: docker/metadata-action@v5 42 | with: 43 | images: ghcr.io/${{ github.repository }} 44 | tags: | 45 | # latest tag for the default branch: 46 | type=raw,value=latest,enable={{is_default_branch}} 47 | - name: ${{ github.ref == 'refs/heads/main' && 'Build and Push Docker image' || 'Build Docker image' }} 48 | uses: docker/build-push-action@v5 49 | with: 50 | context: . 51 | push: ${{ github.ref == 'refs/heads/main'}} 52 | tags: ${{ steps.docker-metadata.outputs.tags }} 53 | labels: ${{ steps.docker-metadata.outputs.labels }} 54 | cache-from: type=gha 55 | cache-to: type=gha,mode=max 56 | 57 | -------------------------------------------------------------------------------- /.github/workflows/haskell.yml: -------------------------------------------------------------------------------- 1 | name: Haskell CI 2 | 3 | on: 4 | workflow_call: 5 | outputs: 6 | VERSION: 7 | description: "VERSION" 8 | value: ${{ jobs.build.outputs.VERSION }} 9 | 10 | permissions: 11 | contents: read 12 | 13 | jobs: 14 | build: 15 | runs-on: ubuntu-22.04 16 | outputs: 17 | VERSION: ${{ steps.get_version.outputs.VERSION }} 18 | steps: 19 | - name: Checkout source code 20 | uses: actions/checkout@v4 21 | - name: Install dependencies (apt-get) 22 | run: | 23 | sudo apt-get update 24 | sudo apt-get install -y --no-install-recommends \ 25 | autoconf \ 26 | automake \ 27 | build-essential \ 28 | ca-certificates \ 29 | chrony \ 30 | dpkg-dev \ 31 | gcc \ 32 | gnupg \ 33 | g++ \ 34 | hlint \ 35 | libc6-dev \ 36 | libncursesw5 \ 37 | libffi-dev \ 38 | libgmp-dev \ 39 | liblzma-dev \ 40 | libnuma-dev \ 41 | libpq-dev \ 42 | libssl-dev \ 43 | libsystemd-dev \ 44 | libtinfo-dev \ 45 | libtool \ 46 | netbase \ 47 | pkg-config \ 48 | procps \ 49 | tmux \ 50 | xz-utils \ 51 | zlib1g-dev 52 | - name: Validate code (run pre-commit hooks) 53 | uses: pre-commit/action@v3.0.0 54 | with: 55 | extra_args: --verbose --all-files 56 | - name: Setup haskell tooling 57 | uses: haskell-actions/setup@v2 58 | with: 59 | ghc-version: '9.6.5' 60 | cabal-version: '3.12.1.0' 61 | enable-stack: true 62 | stack-version: '2.9' 63 | - name: Setup cache 64 | uses: actions/cache@v4 65 | env: 66 | cache-name: cache-cabal 67 | with: 68 | path: ~/.cabal 69 | key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }} 70 | restore-keys: | 71 | ${{ runner.os }}-build-${{ env.cache-name }}- 72 | ${{ runner.os }}-build- 73 | ${{ runner.os }}- 74 | - name: Install LIBSODIUM 75 | run: | 76 | git clone https://github.com/input-output-hk/libsodium 77 | cd libsodium 78 | git checkout dbb48cc 79 | ./autogen.sh 80 | ./configure 81 | make 82 | sudo make install 83 | sudo ldconfig 84 | - name: Install SEPC256K1 85 | run: | 86 | git clone https://github.com/bitcoin-core/secp256k1 87 | cd secp256k1 88 | git checkout ac83be33d0956faf6b7f61a60ab524ef7d6a473a 89 | ./autogen.sh 90 | ./configure --prefix=/usr --enable-module-schnorrsig --enable-experimental 91 | make 92 | sudo make install 93 | sudo ldconfig 94 | - name: Install BLST 95 | run: | 96 | : ${BLST_VERSION:='v0.3.11'} 97 | git clone --depth 1 --branch ${BLST_VERSION} https://github.com/supranational/blst 98 | cd blst 99 | ./build.sh 100 | cat > libblst.pc << EOF 101 | prefix=/usr/local 102 | exec_prefix=\${prefix} 103 | libdir=\${exec_prefix}/lib 104 | includedir=\${prefix}/include 105 | 106 | Name: libblst 107 | Description: Multilingual BLS12-381 signature library 108 | URL: https://github.com/supranational/blst 109 | Version: ${BLST_VERSION#v} 110 | Cflags: -I\${includedir} 111 | Libs: -L\${libdir} -lblst 112 | EOF 113 | sudo cp libblst.pc /usr/local/lib/pkgconfig/ 114 | sudo cp bindings/blst_aux.h bindings/blst.h bindings/blst.hpp /usr/local/include/ 115 | sudo cp libblst.a /usr/local/lib 116 | sudo chmod u=rw,go=r /usr/local/{lib/{libblst.a,pkgconfig/libblst.pc},include/{blst.{h,hpp},blst_aux.h}} 117 | - name: Update dependencies (cabal) 118 | run: cabal update 119 | - name: Install fourmolu 120 | run: cabal install fourmolu --overwrite-policy=always 121 | - name: Run checks (fourmolu) 122 | run: | 123 | fourmolu --mode check geniusyield-dex-api 124 | fourmolu --mode check geniusyield-orderbot-lib 125 | fourmolu --mode check geniusyield-server-lib 126 | - name: Build all targets (cabal) 127 | run: cabal build all --enable-tests --enable-benchmarks 128 | -------------------------------------------------------------------------------- /.github/workflows/release.yml: -------------------------------------------------------------------------------- 1 | name: Release 2 | 3 | on: 4 | push: 5 | tags: 6 | - "v*" 7 | 8 | permissions: 9 | contents: write 10 | 11 | jobs: 12 | build: 13 | uses: ./.github/workflows/haskell.yml 14 | secrets: inherit 15 | release: 16 | runs-on: ubuntu-22.04 17 | needs: build 18 | steps: 19 | - name: Checkout source code 20 | uses: actions/checkout@v3 21 | - uses: actions/download-artifact@v4.1.7 22 | name: Download source distribution file artifact 23 | with: 24 | name: source-distribution-file 25 | path: ./artifacts 26 | - uses: actions/download-artifact@v4.1.7 27 | name: Download haddock artifact 28 | with: 29 | name: github-pages 30 | path: ./artifacts 31 | - name: Create release draft (GitHub) 32 | env: 33 | VERSION: ${{needs.build.outputs.VERSION}} 34 | run: | 35 | export GH_TOKEN=${{ secrets.GITHUB_TOKEN }} 36 | SEMANTIC_VERSION=v${VERSION/#geniusyield-dex-api-} 37 | TAGS=$(git describe --tags) 38 | GIT_REVISION=$(git rev-parse HEAD) 39 | CI_BUILD_TIME=$(date --iso-8601=seconds --utc) 40 | echo "VERSION: ${{ env.VERSION }}" 41 | echo "SEMANTIC_VERSION: $SEMANTIC_VERSION" 42 | echo "TAGS: $TAGS" 43 | echo "GIT_REVISION: $GIT_REVISION" 44 | echo "CI_BUILD_TIME: $CI_BUILD_TIME" 45 | HADDOCK_FILE=${{ env.VERSION }}-haddock.tar 46 | set -x 47 | mv ./artifacts/artifact.tar ./artifacts/${HADDOCK_FILE} 48 | gh release create \ 49 | --generate-notes \ 50 | --verify-tag \ 51 | --draft \ 52 | "${SEMANTIC_VERSION}" \ 53 | "./artifacts/${{ env.VERSION }}.tar.gz#Source distribution file (tar.gz)" \ 54 | "./artifacts/${HADDOCK_FILE}#Haddock (tar)" 55 | echo "::notice::Succesfully created release draft ${SEMANTIC_VERSION} from ${GIT_REVISION}. (Uploaded: ${{ env.VERSION }}.tar.gz)" 56 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.hie 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | .hpc 12 | .hsenv 13 | .cabal-sandbox/ 14 | cabal.sandbox.config 15 | *.prof 16 | *.aux 17 | *.hp 18 | *.eventlog 19 | .stack-work/ 20 | cabal.project.local 21 | cabal.project.local~ 22 | .HTF/ 23 | .ghc.environment.* 24 | .DS_Store 25 | *.skey 26 | secrets/ 27 | *.env 28 | .vscode 29 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "cardano-configurations"] 2 | path = cardano-configurations 3 | url = https://github.com/input-output-hk/cardano-configurations.git 4 | branch = 692010ed0f454bfbb566c06443227c79e2f4dbab 5 | -------------------------------------------------------------------------------- /.pre-commit-config.yaml: -------------------------------------------------------------------------------- 1 | repos: 2 | - repo: https://github.com/pre-commit/pre-commit-hooks 3 | rev: v4.4.0 4 | hooks: 5 | - id: check-yaml 6 | - repo: local 7 | hooks: 8 | - id: no-commit-to-main 9 | name: no-commit-to-main 10 | description: Reject commits to main branch (but not on CI) 11 | entry: bash ./no-commit-to-main.sh 12 | always_run: true 13 | language: system 14 | - repo: https://github.com/geniusyield/atlas 15 | rev: 467bb60894cc381ec7aa3eba118aebf58325ffd3 16 | hooks: 17 | - id: hlint-ignore-duplication 18 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing to [`dex-contracts-api`](https://github.com/geniusyield/dex-contracts-api) repository 2 | 3 | Welcome! We're happy to have you join our community and contribute to one of the most powerful & decentralized exchange in the Cardano ecosystem. 4 | 5 | To learn more about GeniusYield DEX, check out the [main application](https://app.geniusyield.co/). 6 | 7 | ## Opening Issues 8 | 9 | Use an [existing template](https://github.com/geniusyield/dex-contracts-api/issues/new/choose) to: 10 | - Report a bug 11 | - Update the docs 12 | - Request a new feature 13 | 14 | Accompany your issue with one or more of the following labels: 15 | - `bug` 16 | - `dependencies` 17 | - `documentation` 18 | - `duplicate` 19 | - `github actions` 20 | - `good first issue` 21 | - `haskell` 22 | - `help wanted` 23 | - `vulnerability` 24 | - `wont fix` 25 | 26 | ## Opening Pull Requests 27 | After opening a pull request, please take the following steps: 28 | - Ensure your PR has one or more corresponding issues (see above) 29 | - [Link your PR](https://docs.github.com/en/issues/tracking-your-work-with-issues/linking-a-pull-request-to-an-issue) to those issues 30 | - Check the [build status](https://github.com/geniusyield/dex-contracts-api/actions/new) of your PR 31 | - Wait for a review and/or approval from one of the code owners 32 | - Merge and celebrate! 33 | 34 | The team will do their best to help you get your PRs across the finish line! 35 | 36 | ## Discussions 37 | Feel free to participate in [discussions](https://github.com/geniusyield/dex-contracts-api/discussions) with the team and community! -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM debian:bookworm-slim as build 2 | 3 | ENV LANG C.UTF-8 4 | 5 | RUN apt-get update && \ 6 | apt-get install -y --no-install-recommends \ 7 | autoconf \ 8 | automake \ 9 | build-essential \ 10 | chrony \ 11 | curl \ 12 | g++ \ 13 | git \ 14 | gnupg2 \ 15 | jq \ 16 | libffi-dev \ 17 | libgmp-dev \ 18 | liblzma-dev \ 19 | libncursesw5 \ 20 | libnuma-dev \ 21 | libpq-dev \ 22 | libssl-dev \ 23 | libsystemd-dev \ 24 | libtinfo-dev \ 25 | libtool \ 26 | lsb-release \ 27 | make \ 28 | pkg-config \ 29 | procps \ 30 | snapd \ 31 | software-properties-common \ 32 | tmux \ 33 | zlib1g-dev && \ 34 | rm -rf /var/lib/apt/lists/* 35 | 36 | # yq: 37 | RUN curl https://github.com/mikefarah/yq/releases/download/v4.6.1/yq_linux_amd64 > /usr/local/bin/yq && chmod +x /usr/local/bin/yq 38 | 39 | # Libsodium: 40 | RUN git clone https://github.com/input-output-hk/libsodium && \ 41 | cd libsodium && \ 42 | git checkout dbb48cc && \ 43 | ./autogen.sh && \ 44 | ./configure && \ 45 | make && \ 46 | make install 47 | 48 | # Libsecp256k1: 49 | RUN git clone https://github.com/bitcoin-core/secp256k1 && \ 50 | cd secp256k1 && \ 51 | git checkout ac83be33d0956faf6b7f61a60ab524ef7d6a473a && \ 52 | ./autogen.sh && \ 53 | ./configure --prefix=/usr/local --enable-module-schnorrsig --enable-experimental && \ 54 | make && \ 55 | make install 56 | 57 | ARG BLST_VERSION=v0.3.11 58 | ENV BLST_VERSION=${BLST_VERSION} 59 | RUN git clone --depth 1 --branch ${BLST_VERSION} https://github.com/supranational/blst && \ 60 | cd blst && \ 61 | ./build.sh && \ 62 | printf 'prefix=/usr/local\nexec_prefix=${prefix}\nlibdir=${exec_prefix}/lib\nincludedir=${prefix}/include\nName: libblst\nDescription: Multilingual BLS12-381 signature library\nURL: https://github.com/supranational/blst\nVersion: '${BLST_VERSION#v}'\nCflags: -I${includedir}\nLibs: -L${libdir} -lblst\n' > libblst.pc && \ 63 | cp libblst.pc /usr/local/lib/pkgconfig/ && \ 64 | cp bindings/blst_aux.h bindings/blst.h bindings/blst.hpp /usr/local/include/ && \ 65 | cp libblst.a /usr/local/lib && \ 66 | chmod 644 /usr/local/lib/libblst.a && \ 67 | chmod 644 /usr/local/lib/pkgconfig/libblst.pc && \ 68 | chmod 644 /usr/local/include/blst.h && \ 69 | chmod 644 /usr/local/include/blst.hpp && \ 70 | chmod 644 /usr/local/include/blst_aux.h 71 | 72 | ENV LD_LIBRARY_PATH="/usr/local/lib:$LD_LIBRARY_PATH" 73 | ENV PKG_CONFIG_PATH="/usr/local/lib/pkgconfig:$PKG_CONFIG_PATH" 74 | 75 | # Install gpg keys (https://www.haskell.org/ghcup/install/): 76 | RUN gpg --batch --keyserver keyserver.ubuntu.com --recv-keys 7D1E8AFD1D4A16D71FADA2F2CCC85C0E40C06A8C && \ 77 | gpg --batch --keyserver keyserver.ubuntu.com --recv-keys FE5AB6C91FEA597C3B31180B73EDE9E8CFBAEF01 && \ 78 | gpg --batch --keyserver keyserver.ubuntu.com --recv-keys 88B57FCF7DB53B4DB3BFA4B1588764FBE22D19C4 && \ 79 | gpg --batch --keyserver keyserver.ubuntu.com --recv-keys EAF2A9A722C0C96F2B431CA511AAD8CEDEE0CAEF 80 | 81 | # ghcup: 82 | ENV BOOTSTRAP_HASKELL_NONINTERACTIVE=1 83 | ENV BOOTSTRAP_HASKELL_GHC_VERSION=9.6.5 84 | ENV BOOTSTRAP_HASKELL_CABAL_VERSION=3.12.1.0 85 | RUN bash -c "curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh" 86 | ENV PATH=${PATH}:/root/.local/bin 87 | ENV PATH=${PATH}:/root/.ghcup/bin 88 | 89 | # ==================================[ BUILD ]======================================== 90 | WORKDIR /DEX 91 | 92 | # TODO: first build only dependencies 93 | 94 | COPY . . 95 | 96 | # TODO: Fix revision information [Broken revision information in the bot backend #28] 97 | RUN git init && \ 98 | git config --global user.email "ci@github.com" && \ 99 | git config --global user.name "CI" && \ 100 | git add . && \ 101 | git commit -m "Dummy commit" 102 | RUN cabal update 103 | RUN cabal build all --enable-tests --enable-benchmarks 104 | RUN cp $(cabal list-bin geniusyield-server) /DEX/geniusyield-server 105 | 106 | # =============================[ SERVER ]================================ 107 | FROM debian:bookworm-slim 108 | 109 | ENV LANG C.UTF-8 110 | 111 | RUN apt-get update && \ 112 | apt-get install -y --no-install-recommends \ 113 | libgmp10 \ 114 | libpq5 \ 115 | libssl3 \ 116 | libsystemd0 \ 117 | libtinfo6 \ 118 | procps && \ 119 | rm -rf /var/lib/apt/lists/* 120 | 121 | COPY --from=build /usr/local/lib /usr/local/lib 122 | COPY --from=build /usr/local/bin/yq /usr/local/bin/yq 123 | COPY --from=build /DEX/start.sh /DEX/start.sh 124 | COPY --from=build /DEX/geniusyield-server /usr/local/bin/geniusyield-server 125 | COPY --from=build /DEX/web /DEX/web 126 | 127 | ENV LD_LIBRARY_PATH="/usr/local/lib:$LD_LIBRARY_PATH" 128 | 129 | WORKDIR /DEX 130 | 131 | LABEL org.opencontainers.image.source="https://github.com/geniusyield/dex-contracts-api" 132 | 133 | ENTRYPOINT ["/bin/bash", "./start.sh"] 134 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all : build pull start stop 2 | .PHONY : all 3 | 4 | 5 | build: 6 | docker build -t ghcr.io/geniusyield/dex-contracts-api . 7 | 8 | pull: 9 | docker compose pull 10 | 11 | start: 12 | docker compose up -d --remove-orphans 13 | 14 | start-kupo: 15 | docker-compose -f docker-compose-kupo.yml up -d 16 | 17 | node-logs: 18 | docker compose logs -f node 19 | 20 | logs: 21 | docker compose logs -f 22 | 23 | stop: 24 | docker compose down 25 | 26 | test: 27 | @[ ! -f .env ] || export $(grep -v 'SERVER_API_KEY' .env | xargs) >/dev/null 2>&1 28 | @curl -H "api-key: ${SERVER_API_KEY}" http://localhost:8082/v0/settings && echo 29 | -------------------------------------------------------------------------------- /SECURITY.md: -------------------------------------------------------------------------------- 1 | # Security Policy 2 | 3 | ## Reporting a Vulnerability 4 | 5 | ### Smart contracts - Bug bounty program 6 | 7 | As part of our commitment to the security of [our smart contracts](https://github.com/geniusyield/dex-contracts-api/tree/main/geniusyield-onchain), we are inviting ethical hackers and security researchers to help us identify vulnerabilities in our smart contracts. 8 | By participating in our program, you will have the opportunity to earn rewards for responsibly disclosing and reporting security issues to us. 9 | Please find the terms and conditions, and how to submit reports here : https://immunefi.com/bug-bounty/geniusyield/ 10 | 11 | ### Others 12 | 13 | For any vulnerability outside the smart contracts scope, please report with the built-in Github functionality in the *Security* tab: 14 | - [Security Advisories](https://github.com/geniusyield/market-maker/security/advisories) 15 | 16 | Further information is availabe in the official GitHub Documentation: 17 | - [GitHub Documentation: Privately reporting a security vulnerability](https://docs.github.com/en/code-security/security-advisories/guidance-on-reporting-and-writing/privately-reporting-a-security-vulnerability) 18 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | repository cardano-haskell-packages 2 | url: https://input-output-hk.github.io/cardano-haskell-packages 3 | secure: True 4 | root-keys: 5 | 3e0cce471cf09815f930210f7827266fd09045445d65923e6d0238a6cd15126f 6 | 443abb7fb497a134c343faf52f0b659bd7999bc06b7f63fa76dc99d631f9bea1 7 | a86a1f6ce86c449c46666bda44268677abf29b5b2d2eb5ec7af903ec2f117a82 8 | bcec67e8e99cabfa7764d75ad9b158d72bfacf70ca1d0ec8bc6b4406d1bf8413 9 | c00aae8461a256275598500ea0e187588c35a5d5d7454fb57eac18d9edb86a56 10 | d4a35cd3121aa00d18544bb0ac01c3e1691d618f462c46129271bccf39f7e8ee 11 | 12 | packages: 13 | geniusyield-dex-api 14 | geniusyield-orderbot-lib 15 | geniusyield-server-lib 16 | geniusyield-onchain/geniusyield-common 17 | 18 | -- repeating the index-state for hackage to work around hackage.nix parsing limitation 19 | index-state: 2024-10-10T00:52:24Z 20 | 21 | -- NOTE: Do not bump chap index beyond that used by target cardano-node version. 22 | index-state: 23 | , hackage.haskell.org 2024-10-10T00:52:24Z 24 | , cardano-haskell-packages 2024-11-26T16:00:26Z 25 | 26 | -- TODO: Default value should be @direct@ in upcoming 3.10 version of cabal, omit this line then. 27 | test-show-details: direct 28 | 29 | source-repository-package 30 | type: git 31 | location: https://github.com/geniusyield/ply 32 | tag: f3190d3c6e09d8067525e0df4418a55bbace2625 33 | --sha256: sha256-0RhTit7Z9qTBaJufgeVYyhWSsJZbmGbiH88eKMfWIR8= 34 | subdir: ply-core 35 | 36 | source-repository-package 37 | type: git 38 | location: https://github.com/geniusyield/atlas 39 | tag: v0.11.1 40 | --sha256: sha256-leT3lll0Fms4fjPuRqUBSRqjl28ARI+vIs1Xn14VO98= 41 | 42 | -------- Begin contents from @atlas@'s @cabal.project@ file. -------- 43 | 44 | package cardano-crypto-praos 45 | flags: -external-libsodium-vrf 46 | 47 | source-repository-package 48 | type: git 49 | location: https://github.com/maestro-org/haskell-sdk 50 | tag: v1.7.3 51 | --sha256: sha256-FYZMbh9Uz+RIjjXIf3PBK94mhd1XMX/wxHDA9LukvQg= 52 | 53 | -- TODO: Temporary, until proposed changes are in upstream (track https://github.com/mlabs-haskell/clb/pull/62) 54 | source-repository-package 55 | type: git 56 | location: https://github.com/sourabhxyz/clb 57 | tag: 257475d987994db8dc5b1b27c9cdf6d6ea547a2c 58 | --sha256: sha256-Tf9Pxh0W1cyvqPKKA07VVZCOLJBMk8W7BVLV+jwZeOM= 59 | subdir: 60 | clb 61 | emulator 62 | 63 | -- Obtaining cardano-node stuff for 10.1.3 as cardano-testnet version available on CHaP is not correctly updated. 64 | source-repository-package 65 | type: git 66 | location: https://github.com/IntersectMBO/cardano-node 67 | tag: 10.1.3 68 | --sha256: sha256-v0q8qHdI6LKc8mP43QZt3UGdTNDQXE0aF6QapvZsTvU= 69 | subdir: 70 | cardano-node 71 | cardano-testnet 72 | trace-dispatcher 73 | 74 | -- TODO: Temporary, track https://github.com/IntersectMBO/cardano-api/issues/714. 75 | source-repository-package 76 | type: git 77 | location: https://github.com/sourabhxyz/cardano-api 78 | tag: 7081a82a4c6dd57cc0ab01027a18233d3bca2b3e 79 | --sha256: sha256-JGyNbkEkBl69mfMc42Sq4sBwR2IY84aO2WcQihSKdLM= 80 | subdir: 81 | cardano-api 82 | cardano-api-gen 83 | 84 | source-repository-package 85 | type: git 86 | location: https://github.com/cardano-foundation/cardano-wallet 87 | tag: 630ef0067c2c0df1b398256d75923db928beefa1 88 | --sha256: sha256-0iDG3LW60pb+ih+nfqQ3vR+WI7JEm+0kI3Vg7jqm1L0= 89 | subdir: 90 | lib/crypto-primitives/ 91 | lib/coin-selection/ 92 | lib/delta-types/ 93 | lib/launcher/ 94 | lib/numeric/ 95 | lib/primitive/ 96 | lib/test-utils/ 97 | lib/text-class/ 98 | 99 | ------ Following is mostly from @cardano-wallet@'s @cabal.project@ file. ------- 100 | 101 | -------------------------------------------------------------------------------- 102 | -- BEGIN Cardano Addresses Dependency 103 | 104 | source-repository-package 105 | type: git 106 | location: https://github.com/IntersectMBO/cardano-addresses 107 | tag: 2bca06deaa60e54a5322ac757387d744bf043367 108 | --sha256: 1y1mzfly7jac40b9g4xc078rcm5zqhc3xxv77kwxi10yph1jwq7z 109 | subdir: command-line 110 | core 111 | 112 | -- Normally cabal won't apply ghc-options which we specify to build packages 113 | -- to their "regular" dependencies. 114 | -- However, the dependencies declared using the `source-repository-package` 115 | -- pragma are an exception to this rule. 116 | -- This is why we need to manually control options that are applied to the 117 | -- `cardano-addresses` package by declaring them explicitly here. 118 | package cardano-addresses-cli 119 | ghc-options: 120 | -Wwarn=deprecations 121 | 122 | package cardano-addresses 123 | ghc-options: 124 | -Wwarn=incomplete-uni-patterns 125 | -- END Cardano Addresses Dependency 126 | -------------------------------------------------------------------------------- 127 | 128 | source-repository-package 129 | type: git 130 | location: https://github.com/input-output-hk/cardano-sl-x509 131 | tag: a91add165152fa36f08e95fafe7da24f1dba4690 132 | --sha256: 1ia8vlqghis92cla8qmqa6kh8f3jn29b01fshyk5hmgy5373s684 133 | 134 | source-repository-package 135 | type: git 136 | location: https://github.com/cardano-foundation/cardano-wallet-client.git 137 | tag: 353412ca621dc28af53e4a19795338b19bab1b7b 138 | --sha256: 04q58c82wy6x9nkwqbvcxbv6s61fx08h5kf62sb511aqp08id4bb 139 | subdir: generated 140 | 141 | source-repository-package 142 | type: git 143 | location: https://github.com/cardano-foundation/cardano-wallet-agda 144 | tag: f3479b501a2efe50bcf1ee0d09bc2d1325a982e7 145 | --sha256: 10d6k7mw1zw9vpzz8dhb52vfmj2rshsk225nvyl8nrc94fr627kz 146 | subdir: 147 | lib/customer-deposit-wallet-pure 148 | lib/cardano-wallet-read 149 | 150 | -------------------------------------------------------------------------------- 151 | -- BEGIN Constraints tweaking section 152 | 153 | allow-newer: 154 | async-timer:unliftio-core 155 | , katip:Win32 156 | , ekg-wai:time 157 | 158 | constraints: 159 | base >= 4.18.2.0 && < 5 160 | , openapi3 >= 3.2.0 161 | , persistent ^>= 2.14.6.0 162 | 163 | , bech32 >= 1.1.7 164 | 165 | -- lower versions of katip won't build with the Win32-2.12.0.1 166 | -- which is shipped with the ghc-9.2.8 167 | , katip >= 0.8.7.4 168 | 169 | 170 | -- Cardano Node dependencies: 171 | , io-classes >= 1.4 172 | , io-classes -asserts 173 | 174 | , cardano-ledger-api ^>= 1.9 175 | 176 | , ouroboros-network ^>= 0.17 177 | 178 | -- END Constraints tweaking section 179 | -------------------------------------------------------------------------------- 180 | 181 | -------------------------------------------------------------------------------- 182 | -- Flags for dependencies without an S-R-P pragma should be kept in this section 183 | -- (conversely, flags for the S-R-P dependencies should be kept within the 184 | -- same section where an S-R-P pragma is located, 185 | -- for them to be managed together) 186 | 187 | -- Using RDRAND instead of /dev/urandom as an entropy source for key 188 | -- generation is dubious. Set the flag so we use /dev/urandom by default. 189 | package cryptonite 190 | flags: -support_rdrand 191 | 192 | package cardano-config 193 | flags: -systemd 194 | 195 | package cardano-node 196 | flags: -systemd 197 | 198 | package bitvec 199 | flags: -simd 200 | 201 | -- ------------------------------------------------------------------------- 202 | 203 | -------- End contents from @cardano-wallet@'s @cabal.project@ file. -------- 204 | -------- End contents from @atlas@'s @cabal.project@ file. -------- 205 | 206 | -------------------------------------------------------------------------------- /docker-compose-kupo.yml: -------------------------------------------------------------------------------- 1 | version: '3.8' 2 | services: 3 | server: 4 | image: ghcr.io/geniusyield/dex-contracts-api:latest 5 | container_name: server 6 | restart: always 7 | volumes: ["node-ipc:/ipc"] 8 | ports: ["8082:8082"] 9 | depends_on: { node: { condition: service_healthy } } 10 | environment: 11 | MAESTRO_API_KEY: ${MAESTRO_API_KEY} 12 | SERVER_API_KEY: ${SERVER_API_KEY} 13 | SEED_PHRASE: ${SEED_PHRASE} 14 | SERVER_CONFIG: | 15 | coreProvider: 16 | socketPath: /ipc/node.socket 17 | kupoUrl: "kupo:1442" 18 | networkId: mainnet 19 | logging: [{type: {tag: stderr}, severity: "Debug", verbosity: "V2"}] 20 | maestroToken: <> 21 | serverApiKey: <> 22 | wallet: 23 | tag: mnemonicWallet 24 | contents: 25 | mnemonic: <> 26 | port: 8082 27 | kupo: 28 | image: cardanosolutions/kupo:v2.8.0 29 | container_name: kupo 30 | restart: always 31 | volumes: ["node-ipc:/ipc", "./cardano-configurations/network:/network"] 32 | ports: ['1442:1442'] 33 | depends_on: { node: { condition: service_healthy } } 34 | command: [ 35 | --node-socket, /ipc/node.socket, 36 | --since, origin, 37 | --match, "*", 38 | --host, "0.0.0.0", 39 | --node-config, "/network/${NETWORK-mainnet}/cardano-node/config.json", 40 | --workdir, 41 | --prune-utxo, 42 | ] 43 | healthcheck: 44 | test: ["CMD", "/bin/kupo", "health-check"] 45 | interval: 30s 46 | timeout: 10s 47 | retries: 100 48 | node: 49 | image: ghcr.io/intersectmbo/cardano-node:8.9.1 50 | container_name: node 51 | restart: always 52 | environment: 53 | - NETWORK=${NETWORK-mainnet} 54 | volumes: ["${NETWORK-mainnet}-node-db:/data/db", "node-ipc:/ipc"] 55 | healthcheck: 56 | test: ["CMD", "test", "-S", "/ipc/node.socket"] 57 | interval: 30s 58 | timeout: 10s 59 | retries: 100 60 | volumes: 61 | preprod-node-db: null 62 | mainnet-node-db: null 63 | node-ipc: null 64 | -------------------------------------------------------------------------------- /docker-compose.yml: -------------------------------------------------------------------------------- 1 | version: '3.8' 2 | services: 3 | server: 4 | image: ghcr.io/geniusyield/dex-contracts-api:latest 5 | container_name: server 6 | restart: always 7 | ports: 8 | - "8082:8082" 9 | environment: 10 | CORE_MAESTRO_API_KEY: ${CORE_MAESTRO_API_KEY} 11 | MAESTRO_API_KEY: ${MAESTRO_API_KEY} 12 | SERVER_API_KEY: ${SERVER_API_KEY} 13 | SEED_PHRASE: ${SEED_PHRASE} 14 | SERVER_CONFIG: | 15 | coreProvider: 16 | maestroToken: <> 17 | turboSubmit: false 18 | networkId: mainnet 19 | logging: [{type: {tag: stderr}, severity: "Debug", verbosity: "V2"}] 20 | maestroToken: <> 21 | serverApiKey: <> 22 | wallet: 23 | tag: mnemonicWallet 24 | contents: 25 | mnemonic: <> 26 | port: 8082 27 | -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | # Number of spaces per indentation step 2 | indentation: 2 3 | 4 | # Max line length for automatic line breaking 5 | column-limit: none 6 | 7 | # Styling of arrows in type signatures (choices: trailing, leading, or leading-args) 8 | function-arrows: leading 9 | 10 | # How to place commas in multi-line lists, records, etc. (choices: leading or trailing) 11 | comma-style: trailing 12 | 13 | # Styling of import/export lists (choices: leading, trailing, or diff-friendly) 14 | import-export-style: diff-friendly 15 | 16 | # Whether to full-indent or half-indent 'where' bindings past the preceding body 17 | indent-wheres: false 18 | 19 | # Whether to leave a space before an opening record brace 20 | record-brace-space: true 21 | 22 | # Number of spaces between top-level declarations 23 | newlines-between-decls: 1 24 | 25 | # How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact) 26 | haddock-style: multi-line 27 | 28 | # How to print module docstring 29 | haddock-style-module: null 30 | 31 | # Styling of let blocks (choices: auto, inline, newline, or mixed) 32 | let-style: auto 33 | 34 | # How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space) 35 | in-style: right-align 36 | 37 | # Whether to put parentheses around a single constraint (choices: auto, always, or never) 38 | single-constraint-parens: never 39 | 40 | # Output Unicode syntax (choices: detect, always, or never) 41 | unicode: always 42 | 43 | # Give the programmer more choice on where to insert blank lines 44 | respectful: false 45 | 46 | # Fixity information for operators 47 | fixities: [] 48 | 49 | -------------------------------------------------------------------------------- /geniusyield-dex-api/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for geniusyield-dex-api 2 | 3 | ## 0.5.1.0 -- 2024-02-14 4 | 5 | * Update to Atlas v0.11.1. 6 | 7 | ## 0.5.0.0 -- 2024-08-30 8 | 9 | * Update to Atlas v0.6.0. 10 | 11 | ## 0.4.0.0 -- 2024-06-27 12 | 13 | * Updates definition of `fillMultiplePartialOrders'` to call `buildWithFeeOutput` even in case more than one order is being filled. 14 | 15 | ## 0.3.1.0 -- 2024-06-06 16 | 17 | * Adds a fix to earlier `0.3.0.0`, to actually consider `poiRawDatum` as witness. 18 | 19 | ## 0.3.0.0 -- 2024-06-05 20 | 21 | * Updates to make use of latest Atlas commit, `1c20f2a65de8e087b495d1f3ad524d6e659167ad`. 22 | * Uses original UTxO's datum to provide for witness to prevent for round-trip issues. 23 | 24 | ## 0.2.1.0 -- 2024-05-07 25 | 26 | * Adds `placePartialOrder''`, `placePartialOrderWithVersion''` to also return for order's NFT token. 27 | * Exports `placePartialOrder''`, `placePartialOrderWithVersion`, `placePartialOrderWithVersion'` and `placePartialOrderWithVersion''`. 28 | 29 | ## 0.2.0.0 -- 2024-04-17 30 | 31 | * Adds support for v1.1 family of scripts. 32 | * Adds CIP-20 metadata messages on transactions. 33 | 34 | ## 0.1.0.0 -- 2023-12-22 35 | 36 | * First version. 37 | -------------------------------------------------------------------------------- /geniusyield-dex-api/README.md: -------------------------------------------------------------------------------- 1 | # GeniusYield DEX Contracts Haskell API 2 | 3 | This package hosts off-chain code to interact with DEX smart contracts. 4 | 5 | Main file of interest is [`PartialOrder.hs`](./src/GeniusYield/Api/Dex/PartialOrder.hs) and provides various useful API functions among those related to interacting with order's contract. 6 | 7 | Order's contract offers three interaction for an existing order, namely: 8 | 9 | * Completely filling it. 10 | * Only partially filling it with a specified amount. 11 | * Cancelling it. 12 | 13 | These are represented in redeemer as: 14 | 15 | https://github.com/geniusyield/dex-contracts-api/blob/8add6b608235095fa019fb6566d8ef1cd81080bf/src/GeniusYield/Scripts/Dex/PartialOrder.hs#L112-L116 16 | 17 | And following is the specification of datum: 18 | 19 | https://github.com/geniusyield/dex-contracts-api/blob/8add6b608235095fa019fb6566d8ef1cd81080bf/src/GeniusYield/Scripts/Dex/PartialOrder.hs#L75-L108 20 | 21 | Where `PartialOrderContainedFee` is defined to be: 22 | 23 | https://github.com/geniusyield/dex-contracts-api/blob/8add6b608235095fa019fb6566d8ef1cd81080bf/src/GeniusYield/Scripts/Dex/PartialOrder.hs#L39-L48 24 | 25 | ## Order creation 26 | 27 | Order can be created as described in the following snippet: 28 | 29 | https://github.com/geniusyield/dex-contracts-api/blob/cdc81e96ee45411786fa160bab51eff1bc281316/src/GeniusYield/Api/Dex/PartialOrder.hs#L429-L542 30 | 31 | ## Order fill 32 | 33 | And following describes how an existing order can be filled for both the cases, namely partial & complete. 34 | 35 | https://github.com/geniusyield/dex-contracts-api/blob/cdc81e96ee45411786fa160bab51eff1bc281316/src/GeniusYield/Api/Dex/PartialOrder.hs#L544-L693 36 | 37 | ## Order cancellation 38 | 39 | Lastly, existing order can be canceled by it's owner, as described in linked snippet: 40 | 41 | https://github.com/geniusyield/dex-contracts-api/blob/cdc81e96ee45411786fa160bab51eff1bc281316/src/GeniusYield/Api/Dex/PartialOrder.hs#L695-L751 42 | -------------------------------------------------------------------------------- /geniusyield-dex-api/geniusyield-dex-api.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.6 2 | name: geniusyield-dex-api 3 | 4 | -- PVP summary: +-+------- breaking API changes 5 | -- | | +----- non-breaking API additions 6 | -- | | | +--- code changes with no API change 7 | version: 0.5.1.0 8 | synopsis: API code to interact with GeniusYield DEX. 9 | description: 10 | API code to interact with GeniusYield DEX. Learn more about GeniusYield by visiting https://www.geniusyield.co/. 11 | 12 | license: Apache-2.0 13 | license-file: LICENSE 14 | author: GeniusYield 15 | maintainer: support@geniusyield.co 16 | copyright: 2023 GYELD GMBH 17 | build-type: Simple 18 | category: Blockchain, Cardano, Validator 19 | extra-doc-files: 20 | CHANGELOG.md 21 | README.md 22 | 23 | tested-with: GHC ==9.6.5 24 | 25 | source-repository head 26 | type: git 27 | location: https://github.com/geniusyield/dex-contracts-api 28 | 29 | common common 30 | default-language: GHC2021 31 | default-extensions: 32 | DataKinds 33 | DeriveAnyClass 34 | DerivingStrategies 35 | DerivingVia 36 | GADTs 37 | LambdaCase 38 | MultiWayIf 39 | OverloadedStrings 40 | RecordWildCards 41 | RoleAnnotations 42 | TemplateHaskell 43 | TypeFamilies 44 | UndecidableInstances 45 | UnicodeSyntax 46 | ViewPatterns 47 | 48 | ghc-options: -Wall -Wincomplete-uni-patterns -Wunused-packages 49 | 50 | -- Speed-ups GHCi considerably. 51 | ghc-options: -fno-show-valid-hole-fits 52 | 53 | library 54 | import: common 55 | hs-source-dirs: src 56 | exposed-modules: 57 | GeniusYield.Api.Dex.Constants 58 | GeniusYield.Api.Dex.PartialOrder 59 | GeniusYield.Api.Dex.PartialOrderConfig 60 | GeniusYield.Api.Dex.Types 61 | GeniusYield.Scripts 62 | GeniusYield.Scripts.Common 63 | GeniusYield.Scripts.Dex 64 | GeniusYield.Scripts.Dex.Data 65 | GeniusYield.Scripts.Dex.Nft 66 | GeniusYield.Scripts.Dex.PartialOrder 67 | GeniusYield.Scripts.Dex.PartialOrderConfig 68 | GeniusYield.Scripts.Dex.PartialOrderConfig.Internal 69 | GeniusYield.Scripts.Dex.PartialOrderNft 70 | GeniusYield.Scripts.Dex.Version 71 | 72 | build-depends: 73 | , aeson 74 | , base ^>=4.18.2.0 75 | , containers 76 | , data-default 77 | , http-types 78 | , lens 79 | , mtl 80 | , some 81 | , strict 82 | , swagger2 83 | , text 84 | 85 | -- Dependencies whose version is fixed by @cabal.project@ file. 86 | build-depends: 87 | , atlas-cardano 88 | , geniusyield-common 89 | , ply-core 90 | 91 | -- Cardano libraries which are not on hackage. Their version is pinned in @cabal.project@ file or derived from other related dependencies. 92 | build-depends: 93 | , plutus-core 94 | , plutus-ledger-api 95 | , plutus-tx 96 | -------------------------------------------------------------------------------- /geniusyield-dex-api/src/GeniusYield/Api/Dex/Constants.hs: -------------------------------------------------------------------------------- 1 | module GeniusYield.Api.Dex.Constants ( 2 | poRefsMainnet, 3 | poRefsPreprod, 4 | poConfigAddrMainnet, 5 | poConfigAddrPreprod, 6 | DEXInfo (..), 7 | dexInfoDefaultMainnet, 8 | dexInfoDefaultPreprod, 9 | ) where 10 | 11 | import GeniusYield.Api.Dex.PartialOrderConfig (PORef (..), PORefs (..)) 12 | import GeniusYield.OnChain.Common.Scripts.DEX.Data 13 | import GeniusYield.Scripts (HasPartialOrderConfigAddr (..), HasPartialOrderNftScript (..), HasPartialOrderScript (..)) 14 | import GeniusYield.Scripts.Dex.Version (POCVersion (POCVersion1, POCVersion1_1)) 15 | import GeniusYield.Types (GYAddress, unsafeAddressFromText) 16 | import PlutusLedgerApi.V1 (Address) 17 | import PlutusLedgerApi.V1.Scripts (ScriptHash) 18 | import PlutusLedgerApi.V1.Value (AssetClass) 19 | import Ply (ScriptRole (..), TypedScript) 20 | 21 | poRefsMainnet ∷ PORefs 22 | poRefsMainnet = 23 | PORefs 24 | { porV1 = 25 | PORef 26 | { porValRef = "062f97b0e64130bc18b4a227299a62d6d59a4ea852a4c90db3de2204a2cd19ea#2", 27 | porRefNft = "fae686ea8f21d567841d703dea4d4221c2af071a6f2b433ff07c0af2.4aff78908ef2dce98bfe435fb3fd2529747b1c4564dff5adebedf4e46d0fc63d", 28 | porMintRef = "062f97b0e64130bc18b4a227299a62d6d59a4ea852a4c90db3de2204a2cd19ea#1" 29 | }, 30 | porV1_1 = 31 | PORef 32 | { porValRef = "c8adf3262d769f5692847501791c0245068ed5b6746e7699d23152e94858ada7#2", 33 | porRefNft = "fae686ea8f21d567841d703dea4d4221c2af071a6f2b433ff07c0af2.682fd5d4b0d834a3aa219880fa193869b946ffb80dba5532abca0910c55ad5cd", 34 | porMintRef = "c8adf3262d769f5692847501791c0245068ed5b6746e7699d23152e94858ada7#1" 35 | } 36 | } 37 | 38 | poRefsPreprod ∷ PORefs 39 | poRefsPreprod = 40 | PORefs 41 | { porV1 = 42 | PORef 43 | { porValRef = "be6f8dc16d4e8d5aad566ff6b5ffefdda574817a60d503e2a0ea95f773175050#2", 44 | porRefNft = "fae686ea8f21d567841d703dea4d4221c2af071a6f2b433ff07c0af2.8309f9861928a55d37e84f6594b878941edce5e351f7904c2c63b559bde45c5c", 45 | porMintRef = "be6f8dc16d4e8d5aad566ff6b5ffefdda574817a60d503e2a0ea95f773175050#1" 46 | }, 47 | porV1_1 = 48 | PORef 49 | { porValRef = "16647d6365020555d905d6e0edcf08b90a567886f875b40b3d7cec1c70482624#2", 50 | porRefNft = "fae686ea8f21d567841d703dea4d4221c2af071a6f2b433ff07c0af2.b5121487c7661f202bc1f95cbc16f0fce720a0a9d3dba63a9f128e617f2ddedc", 51 | porMintRef = "16647d6365020555d905d6e0edcf08b90a567886f875b40b3d7cec1c70482624#1" 52 | } 53 | } 54 | 55 | poConfigAddrMainnet ∷ POCVersion → GYAddress 56 | poConfigAddrMainnet = 57 | let v1Addr = unsafeAddressFromText "addr1w9zr09hgj7z6vz3d7wnxw0u4x30arsp5k8avlcm84utptls8uqd0z" 58 | v1_1Addr = unsafeAddressFromText "addr1wxcqkdhe7qcfkqcnhlvepe7zmevdtsttv8vdfqlxrztaq2gge58rd" 59 | in \case 60 | POCVersion1 → v1Addr 61 | POCVersion1_1 → v1_1Addr 62 | 63 | poConfigAddrPreprod ∷ POCVersion → GYAddress 64 | poConfigAddrPreprod = 65 | let v1Addr = unsafeAddressFromText "addr_test1wrgvy8fermjrruaf7fnndtmpuw4xx4cnvfqjp5zqu8kscfcvh32qk" 66 | v1_1Addr = unsafeAddressFromText "addr_test1wqzy2cay2twmcq68ypk4wjyppz6e4vjj4udhvkp7dfjet2quuh3la" 67 | in \case 68 | POCVersion1 → v1Addr 69 | POCVersion1_1 → v1_1Addr 70 | 71 | -- | Type that encapsulates the scripts needed for the dex api. 72 | data DEXInfo = DEXInfo 73 | { dexPartialOrderValidator ∷ !(TypedScript 'ValidatorRole '[Address, AssetClass]), 74 | dexNftPolicy ∷ !(POCVersion → TypedScript 'MintingPolicyRole '[ScriptHash, Address, AssetClass]), 75 | dexPartialOrderConfigAddr ∷ !(POCVersion → GYAddress), 76 | dexPORefs ∷ !PORefs 77 | } 78 | 79 | instance HasPartialOrderScript DEXInfo where 80 | getPartialOrderValidator = dexPartialOrderValidator 81 | 82 | instance HasPartialOrderNftScript DEXInfo where 83 | getPartialOrderNftPolicy = dexNftPolicy 84 | 85 | instance HasPartialOrderConfigAddr DEXInfo where 86 | getPartialOrderConfigAddr = dexPartialOrderConfigAddr 87 | 88 | nftPolicy ∷ POCVersion → TypedScript 'MintingPolicyRole '[ScriptHash, Address, AssetClass] 89 | nftPolicy = \case 90 | POCVersion1 → nftPolicyV1 91 | POCVersion1_1 → nftPolicyV1_1 92 | 93 | dexInfoDefaultMainnet ∷ DEXInfo 94 | dexInfoDefaultMainnet = 95 | DEXInfo 96 | { dexPartialOrderValidator = orderValidator, 97 | dexNftPolicy = nftPolicy, 98 | dexPartialOrderConfigAddr = poConfigAddrMainnet, 99 | dexPORefs = poRefsMainnet 100 | } 101 | 102 | dexInfoDefaultPreprod ∷ DEXInfo 103 | dexInfoDefaultPreprod = 104 | DEXInfo 105 | { dexPartialOrderValidator = orderValidator, 106 | dexNftPolicy = nftPolicy, 107 | dexPartialOrderConfigAddr = poConfigAddrPreprod, 108 | dexPORefs = poRefsPreprod 109 | } 110 | -------------------------------------------------------------------------------- /geniusyield-dex-api/src/GeniusYield/Api/Dex/PartialOrderConfig.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module : GeniusYield.Api.Dex.PartialOrderConfig 3 | Copyright : (c) 2023 GYELD GMBH 4 | License : Apache 2.0 5 | Maintainer : support@geniusyield.co 6 | Stability : develop 7 | -} 8 | module GeniusYield.Api.Dex.PartialOrderConfig ( 9 | PORef (..), 10 | SomePORef (..), 11 | withSomePORef, 12 | PORefs (..), 13 | PocdException (..), 14 | fetchPartialOrderConfig, 15 | unsafeFetchPartialOrderConfig, 16 | fetchPartialOrderConfig', 17 | unsafeFetchPartialOrderConfig', 18 | RefPocd (..), 19 | SomeRefPocd (..), 20 | withSomeRefPocd, 21 | RefPocds, 22 | selectV1RefPocd, 23 | selectV1_1RefPocd, 24 | selectRefPocd, 25 | selectRefPocd', 26 | selectPor, 27 | selectPor', 28 | fetchPartialOrderConfigs, 29 | ) where 30 | 31 | import Control.Monad.Reader (ask) 32 | import Data.Strict.Tuple (Pair (..)) 33 | import Data.Text qualified as Txt 34 | import GeniusYield.Api.Dex.Types 35 | import GeniusYield.HTTP.Errors (GYApiError (..), IsGYApiError (..)) 36 | import GeniusYield.Imports 37 | import GeniusYield.Scripts.Dex.PartialOrderConfig ( 38 | HasPartialOrderConfigAddr (getPartialOrderConfigAddr), 39 | PartialOrderConfigInfoF (..), 40 | ) 41 | import GeniusYield.Scripts.Dex.Version 42 | import GeniusYield.TxBuilder ( 43 | GYTxQueryMonad (utxosAtAddressWithDatums), 44 | addressFromPlutus', 45 | throwAppError, 46 | utxoDatumPure', 47 | ) 48 | import GeniusYield.Types ( 49 | GYAddress, 50 | GYAssetClass, 51 | GYTxOutRef, 52 | GYUTxO (utxoRef), 53 | ) 54 | import Network.HTTP.Types (status400) 55 | 56 | data PORef (v ∷ POCVersion) = PORef 57 | { -- | The reference NFT. 58 | porRefNft ∷ !GYAssetClass, 59 | -- | The location of the reference NFT minting policy reference script. 60 | porMintRef ∷ !GYTxOutRef, 61 | -- | The location of the validator reference script. 62 | porValRef ∷ !GYTxOutRef 63 | } 64 | deriving stock (Show, Generic) 65 | deriving anyclass (FromJSON, ToJSON) 66 | 67 | data SomePORef = ∀ v. SingPOCVersionI v ⇒ SomePORef (PORef v) 68 | 69 | withSomePORef ∷ SomePORef → (∀ v. SingPOCVersionI v ⇒ PORef v → r) → r 70 | withSomePORef (SomePORef por) f = f por 71 | 72 | data PORefs = PORefs 73 | { -- | For the V1 version of partial order family of contract. 74 | porV1 ∷ !(PORef 'POCVersion1), 75 | -- | For the V1_1 version of partial order family of contract. 76 | porV1_1 ∷ !(PORef 'POCVersion1_1) 77 | } 78 | deriving stock (Show, Generic) 79 | deriving anyclass (FromJSON, ToJSON) 80 | 81 | newtype PocdException = PocdException GYAssetClass 82 | deriving stock (Show) 83 | deriving anyclass (Exception) 84 | 85 | instance IsGYApiError PocdException where 86 | toApiError (PocdException nftToken) = 87 | GYApiError 88 | { gaeErrorCode = "PARTIAL_ORDER_CONFIG_NOT_FOUND", 89 | gaeHttpStatus = status400, 90 | gaeMsg = Txt.pack $ printf "Partial order config not found for NFT: %s" nftToken 91 | } 92 | 93 | newtype RefPocd (v ∷ POCVersion) = RefPocd (Pair GYTxOutRef (PartialOrderConfigInfoF GYAddress)) 94 | 95 | data SomeRefPocd = ∀ v. SingPOCVersionI v ⇒ SomeRefPocd (RefPocd v) 96 | 97 | withSomeRefPocd ∷ SomeRefPocd → (∀ v. SingPOCVersionI v ⇒ RefPocd v → r) → r 98 | withSomeRefPocd (SomeRefPocd por) f = f por 99 | 100 | newtype RefPocds = RefPocds (Pair (RefPocd 'POCVersion1) (RefPocd 'POCVersion1_1)) 101 | 102 | selectV1RefPocd ∷ RefPocds → RefPocd 'POCVersion1 103 | selectV1RefPocd (RefPocds (p :!: _)) = p 104 | 105 | selectV1_1RefPocd ∷ RefPocds → RefPocd 'POCVersion1_1 106 | selectV1_1RefPocd (RefPocds (_ :!: p)) = p 107 | 108 | selectRefPocd ∷ RefPocds → POCVersion → SomeRefPocd 109 | selectRefPocd refPocds pocVersion = withSomeSingPOCVersion (toSingPOCVersion pocVersion) (\(_ ∷ SingPOCVersion v) → SomeRefPocd (selectRefPocd' @v refPocds)) 110 | 111 | selectRefPocd' ∷ ∀ v. SingPOCVersionI v ⇒ RefPocds → RefPocd v 112 | selectRefPocd' refPocds = case (singPOCVersion @v) of 113 | SingPOCVersion1 → selectV1RefPocd refPocds 114 | SingPOCVersion1_1 → selectV1_1RefPocd refPocds 115 | 116 | selectPor ∷ PORefs → POCVersion → SomePORef 117 | selectPor pors pocVersion = withSomeSingPOCVersion (toSingPOCVersion pocVersion) (\(_ ∷ SingPOCVersion v) → SomePORef (selectPor' @v pors)) 118 | 119 | selectPor' ∷ ∀ v. SingPOCVersionI v ⇒ PORefs → PORef v 120 | selectPor' PORefs {..} = case (singPOCVersion @v) of 121 | SingPOCVersion1 → porV1 122 | SingPOCVersion1_1 → porV1_1 123 | 124 | fetchPartialOrderConfig ∷ GYDexApiQueryMonad m a ⇒ POCVersion → PORefs → m SomeRefPocd 125 | fetchPartialOrderConfig pocVersion pors = 126 | let SomePORef PORef {..} = selectPor pors pocVersion 127 | in unsafeFetchPartialOrderConfig pocVersion porRefNft 128 | 129 | -- | Unsafe as it takes NFT's asset class where this NFT might not belong to the given version. 130 | unsafeFetchPartialOrderConfig ∷ GYDexApiQueryMonad m a ⇒ POCVersion → GYAssetClass → m SomeRefPocd 131 | unsafeFetchPartialOrderConfig pocVersion nftToken = 132 | withSomeSingPOCVersion (toSingPOCVersion pocVersion) $ \(_ ∷ SingPOCVersion v) → SomeRefPocd <$> unsafeFetchPartialOrderConfig' @v nftToken 133 | 134 | -- | Unsafe as it takes NFT's asset class where this NFT might not belong to the given version. 135 | unsafeFetchPartialOrderConfig' ∷ ∀ v m a. (GYDexApiQueryMonad m a, SingPOCVersionI v) ⇒ GYAssetClass → m (RefPocd v) 136 | unsafeFetchPartialOrderConfig' nftToken = do 137 | a ← ask 138 | let pocVersion = fromSingPOCVersion $ singPOCVersion @v 139 | addr = getPartialOrderConfigAddr a pocVersion 140 | utxos ← utxosAtAddressWithDatums addr $ Just nftToken 141 | case utxos of 142 | [p@(utxo, Just _)] → do 143 | (_, _, d') ← utxoDatumPure' p 144 | feeAddr ← addressFromPlutus' $ pociFeeAddr d' 145 | pure $ RefPocd $ utxoRef utxo :!: feeAddr <$ d' 146 | _ → throwAppError $ PocdException nftToken 147 | 148 | fetchPartialOrderConfig' ∷ ∀ v m a. (GYDexApiQueryMonad m a, SingPOCVersionI v) ⇒ PORefs → m (RefPocd v) 149 | fetchPartialOrderConfig' pors = do 150 | let pocVersion = fromSingPOCVersion $ singPOCVersion @v 151 | SomePORef PORef {..} = selectPor pors pocVersion 152 | unsafeFetchPartialOrderConfig' @v porRefNft 153 | 154 | fetchPartialOrderConfigs ∷ GYDexApiQueryMonad m a ⇒ PORefs → m RefPocds 155 | fetchPartialOrderConfigs pors = do 156 | refPocd1 ← fetchPartialOrderConfig' @'POCVersion1 pors 157 | refPocd1_1 ← fetchPartialOrderConfig' @'POCVersion1_1 pors 158 | pure $ RefPocds $ refPocd1 :!: refPocd1_1 159 | -------------------------------------------------------------------------------- /geniusyield-dex-api/src/GeniusYield/Api/Dex/Types.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module : GeniusYield.Api.Dex.Types 3 | Copyright : (c) 2023 GYELD GMBH 4 | License : Apache 2.0 5 | Maintainer : support@geniusyield.co 6 | Stability : develop 7 | -} 8 | module GeniusYield.Api.Dex.Types ( 9 | HasDexScripts, 10 | GYDexApiQueryMonad, 11 | GYDexApiMonad, 12 | ) where 13 | 14 | import Control.Monad.Reader (MonadReader) 15 | import GeniusYield.Scripts.Dex (HasPartialOrderConfigAddr, HasPartialOrderNftScript, HasPartialOrderScript) 16 | import GeniusYield.TxBuilder.Class (GYTxQueryMonad, GYTxUserQueryMonad) 17 | 18 | type HasDexScripts a = (HasPartialOrderConfigAddr a, HasPartialOrderScript a, HasPartialOrderNftScript a) 19 | 20 | type GYDexApiQueryMonad m a = (HasDexScripts a, MonadReader a m, GYTxQueryMonad m) 21 | 22 | type GYDexApiMonad m a = (GYDexApiQueryMonad m a, GYTxUserQueryMonad m) 23 | -------------------------------------------------------------------------------- /geniusyield-dex-api/src/GeniusYield/Scripts.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module : GeniusYield.Scripts 3 | Copyright : (c) 2023 GYELD GMBH 4 | License : Apache 2.0 5 | Maintainer : support@geniusyield.co 6 | Stability : develop 7 | -} 8 | module GeniusYield.Scripts ( 9 | module X, 10 | ) where 11 | 12 | import GeniusYield.Scripts.Common as X 13 | import GeniusYield.Scripts.Dex as X 14 | -------------------------------------------------------------------------------- /geniusyield-dex-api/src/GeniusYield/Scripts/Common.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module : GeniusYield.Scripts.Common 3 | Copyright : (c) 2023 GYELD GMBH 4 | License : Apache 2.0 5 | Maintainer : support@geniusyield.co 6 | Stability : develop 7 | -} 8 | module GeniusYield.Scripts.Common ( 9 | validatorFromPly, 10 | mintingPolicyFromPly, 11 | ) where 12 | 13 | import GeniusYield.Types.PlutusVersion 14 | import GeniusYield.Types.Script 15 | import PlutusLedgerApi.V1 (serialiseUPLC) 16 | import Ply ( 17 | ScriptRole (..), 18 | TypedScript (..), 19 | ) 20 | import Ply qualified 21 | 22 | validatorFromPly ∷ ∀ v. SingPlutusVersionI v ⇒ TypedScript 'ValidatorRole '[] → GYValidator v 23 | validatorFromPly ts = case ver' of 24 | SingPlutusV1 → 25 | if ver == Ply.ScriptV1 26 | then validatorFromSerialisedScript @'PlutusV1 $ toSerialisedValidator ts 27 | else error "validatorFromPly: Invalid script version" 28 | SingPlutusV2 → 29 | if ver == Ply.ScriptV2 30 | then validatorFromSerialisedScript @'PlutusV2 $ toSerialisedValidator ts 31 | else error "validatorFromPly: Invalid script version" 32 | where 33 | ver = Ply.getPlutusVersion ts 34 | ver' = singPlutusVersion @v 35 | toSerialisedValidator (TypedScript _ s) = serialiseUPLC s 36 | 37 | mintingPolicyFromPly ∷ ∀ v. SingPlutusVersionI v ⇒ TypedScript 'MintingPolicyRole '[] → GYMintingPolicy v 38 | mintingPolicyFromPly ts = case ver' of 39 | SingPlutusV1 → 40 | if ver == Ply.ScriptV1 41 | then mintingPolicyFromSerialisedScript @'PlutusV1 $ toSerialisedMintingPolicy ts 42 | else error "mintingPolicyFromPly: Invalid script version" 43 | SingPlutusV2 → 44 | if ver == Ply.ScriptV2 45 | then mintingPolicyFromSerialisedScript @'PlutusV2 $ toSerialisedMintingPolicy ts 46 | else error "mintingPolicyFromPly: Invalid script version" 47 | where 48 | ver = Ply.getPlutusVersion ts 49 | ver' = singPlutusVersion @v 50 | toSerialisedMintingPolicy (TypedScript _ s) = serialiseUPLC s 51 | -------------------------------------------------------------------------------- /geniusyield-dex-api/src/GeniusYield/Scripts/Dex.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module : GeniusYield.Scripts.Dex 3 | Copyright : (c) 2023 GYELD GMBH 4 | License : Apache 2.0 5 | Maintainer : support@geniusyield.co 6 | Stability : develop 7 | -} 8 | module GeniusYield.Scripts.Dex ( 9 | module X, 10 | ) where 11 | 12 | import GeniusYield.Scripts.Dex.PartialOrder as X 13 | import GeniusYield.Scripts.Dex.PartialOrderConfig as X 14 | import GeniusYield.Scripts.Dex.PartialOrderNft as X 15 | -------------------------------------------------------------------------------- /geniusyield-dex-api/src/GeniusYield/Scripts/Dex/Data.hs: -------------------------------------------------------------------------------- 1 | module GeniusYield.Scripts.Dex.Data ( 2 | orderValidator, 3 | nftPolicyV1, 4 | nftPolicyV1_1, 5 | ) where 6 | 7 | import GeniusYield.OnChain.Common.Scripts.DEX.Data ( 8 | nftPolicyV1, 9 | nftPolicyV1_1, 10 | orderValidator, 11 | ) 12 | -------------------------------------------------------------------------------- /geniusyield-dex-api/src/GeniusYield/Scripts/Dex/Nft.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module : GeniusYield.Scripts.Dex.Nft 3 | Copyright : (c) 2023 GYELD GMBH 4 | License : Apache 2.0 5 | Maintainer : support@geniusyield.co 6 | Stability : develop 7 | -} 8 | module GeniusYield.Scripts.Dex.Nft ( 9 | mkNftRedeemer, 10 | 11 | -- * shared functions 12 | expectedTokenName, 13 | gyExpectedTokenName, 14 | ) where 15 | 16 | import Data.Maybe (fromJust) 17 | import GeniusYield.Types 18 | import PlutusLedgerApi.V1 qualified as Plutus ( 19 | TokenName (..), 20 | TxId (..), 21 | TxOutRef (..), 22 | ) 23 | import PlutusTx.Builtins qualified as Plutus ( 24 | BuiltinByteString, 25 | consByteString, 26 | sha2_256, 27 | ) 28 | 29 | mkNftRedeemer ∷ Maybe GYTxOutRef → GYRedeemer 30 | mkNftRedeemer = redeemerFromPlutusData . fmap txOutRefToPlutus 31 | 32 | expectedTokenName ∷ Plutus.TxOutRef → Plutus.TokenName 33 | expectedTokenName (Plutus.TxOutRef (Plutus.TxId tid) ix) = Plutus.TokenName s 34 | where 35 | s ∷ Plutus.BuiltinByteString 36 | s = Plutus.sha2_256 (Plutus.consByteString ix tid) 37 | 38 | gyExpectedTokenName ∷ GYTxOutRef → GYTokenName 39 | gyExpectedTokenName = 40 | fromJust 41 | . tokenNameFromPlutus 42 | . expectedTokenName 43 | . txOutRefToPlutus 44 | -------------------------------------------------------------------------------- /geniusyield-dex-api/src/GeniusYield/Scripts/Dex/PartialOrder.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module : GeniusYield.Scripts.Dex.PartialOrder 3 | Copyright : (c) 2023 GYELD GMBH 4 | License : Apache 2.0 5 | Maintainer : support@geniusyield.co 6 | Stability : develop 7 | -} 8 | module GeniusYield.Scripts.Dex.PartialOrder ( 9 | -- * Typeclass 10 | HasPartialOrderScript (..), 11 | 12 | -- * Validator 13 | partialOrderValidator, 14 | partialOrderValidatorHash, 15 | 16 | -- * Datum 17 | PartialOrderFeeOutput (..), 18 | PartialOrderContainedFee (..), 19 | PartialOrderDatum (..), 20 | 21 | -- * Redeemer 22 | PartialOrderAction (..), 23 | ) where 24 | 25 | import GHC.Generics (Generic) 26 | import GeniusYield.Scripts.Common 27 | import GeniusYield.Scripts.Dex.PartialOrderConfig (HasPartialOrderConfigAddr (getPartialOrderConfigAddr)) 28 | import GeniusYield.Scripts.Dex.Version (POCVersion) 29 | import GeniusYield.Types 30 | import PlutusLedgerApi.V1 (Address, POSIXTime, PubKeyHash, TokenName, TxOutRef, Value) 31 | import PlutusLedgerApi.V1.Value (AssetClass) 32 | import PlutusTx qualified 33 | import PlutusTx.AssocMap qualified as PlutusTx 34 | import PlutusTx.Prelude qualified as PlutusTx 35 | import Ply (ScriptRole (..), TypedScript, (#)) 36 | 37 | class HasPartialOrderScript a where 38 | getPartialOrderValidator ∷ a → TypedScript 'ValidatorRole '[Address, AssetClass] 39 | 40 | -- | Representation of total fees contained in the order. 41 | data PartialOrderContainedFee = PartialOrderContainedFee 42 | { -- | Fees explicitly charged in lovelaces, like flat lovelace fee collected from maker and taker(s). 43 | pocfLovelaces ∷ Integer, 44 | -- | Fees explicitly collected as percentage of offered tokens from maker. 45 | pocfOfferedTokens ∷ Integer, 46 | -- | Fees explicitly collected as percentage of asked tokens from taker. 47 | pocfAskedTokens ∷ Integer 48 | } 49 | deriving (Generic, Show) 50 | 51 | PlutusTx.unstableMakeIsData ''PartialOrderContainedFee 52 | 53 | instance Semigroup PartialOrderContainedFee where 54 | (<>) a b = 55 | PartialOrderContainedFee 56 | { pocfLovelaces = pocfLovelaces a + pocfLovelaces b, 57 | pocfOfferedTokens = pocfOfferedTokens a + pocfOfferedTokens b, 58 | pocfAskedTokens = pocfAskedTokens a + pocfAskedTokens b 59 | } 60 | 61 | instance Monoid PartialOrderContainedFee where mempty = PartialOrderContainedFee 0 0 0 62 | 63 | -- | Datum of the fee output. 64 | data PartialOrderFeeOutput = PartialOrderFeeOutput 65 | { -- | Map, mapping order being consumed to the collected fees. 66 | pofdMentionedFees ∷ PlutusTx.Map TxOutRef Value, 67 | -- | Value reserved in this UTxO which is not to be considered as fees. 68 | pofdReservedValue ∷ Value, 69 | -- | If not @Nothing@, it mentions the UTxO being consumed, whose value is used to provide for UTxOs minimum ada requirement. 70 | pofdSpentUTxORef ∷ Maybe TxOutRef 71 | } 72 | deriving (Generic, Show) 73 | 74 | PlutusTx.unstableMakeIsData ''PartialOrderFeeOutput 75 | 76 | -- | Datum specifying a partial order. 77 | data PartialOrderDatum = PartialOrderDatum 78 | { -- | Public key hash of the owner. Order cancellations must be signed by this. 79 | podOwnerKey ∷ PubKeyHash, 80 | -- | Address of the owner. Payments must be made to this address. 81 | podOwnerAddr ∷ Address, 82 | -- | The asset being offered. 83 | podOfferedAsset ∷ AssetClass, 84 | -- | Original number of units being offered. Initially, this would be same as `podOfferedAmount`. 85 | podOfferedOriginalAmount ∷ Integer, 86 | -- | The number of units being offered. 87 | podOfferedAmount ∷ Integer, 88 | -- | The asset being asked for as payment. 89 | podAskedAsset ∷ AssetClass, 90 | -- | The price for one unit of the offered asset. 91 | podPrice ∷ PlutusTx.Rational, 92 | -- | Token name of the NFT identifying this order. 93 | podNFT ∷ TokenName, 94 | -- | The time when the order can earliest be filled (optional). 95 | podStart ∷ Maybe POSIXTime, 96 | -- | The time when the order can latest be filled (optional). 97 | podEnd ∷ Maybe POSIXTime, 98 | -- | Number of partial fills order has undergone, initially would be 0. 99 | podPartialFills ∷ Integer, 100 | -- | Flat fee (in lovelace) paid by the maker. 101 | podMakerLovelaceFlatFee ∷ Integer, 102 | -- | Flat fee (in lovelace) paid by the taker. 103 | podTakerLovelaceFlatFee ∷ Integer, 104 | -- | Total fees contained in the order. 105 | podContainedFee ∷ PartialOrderContainedFee, 106 | -- | Payment (in asked asset) contained in the order. 107 | podContainedPayment ∷ Integer 108 | } 109 | deriving (Generic, Show) 110 | 111 | PlutusTx.unstableMakeIsData ''PartialOrderDatum 112 | 113 | data PartialOrderAction 114 | = PartialCancel 115 | | PartialFill Integer 116 | | CompleteFill 117 | deriving (Generic, Show) 118 | 119 | PlutusTx.makeIsDataIndexed ''PartialOrderAction [('PartialCancel, 0), ('PartialFill, 1), ('CompleteFill, 2)] 120 | 121 | partialOrderValidator ∷ (HasPartialOrderScript a, HasPartialOrderConfigAddr a) ⇒ a → POCVersion → GYAssetClass → GYValidator 'PlutusV2 122 | partialOrderValidator a pocVersion ac = 123 | validatorFromPly $ 124 | getPartialOrderValidator a 125 | # addressToPlutus (getPartialOrderConfigAddr a pocVersion) 126 | # assetClassToPlutus ac 127 | 128 | partialOrderValidatorHash 129 | ∷ (HasPartialOrderScript a, HasPartialOrderConfigAddr a) 130 | ⇒ a 131 | → POCVersion 132 | → GYAssetClass 133 | → GYValidatorHash 134 | partialOrderValidatorHash a pocVersion = validatorHash . partialOrderValidator a pocVersion 135 | -------------------------------------------------------------------------------- /geniusyield-dex-api/src/GeniusYield/Scripts/Dex/PartialOrderConfig.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module : GeniusYield.Scripts.Dex.PartialOrderConfig 3 | Copyright : (c) 2023 GYELD GMBH 4 | License : Apache 2.0 5 | Maintainer : support@geniusyield.co 6 | Stability : develop 7 | -} 8 | module GeniusYield.Scripts.Dex.PartialOrderConfig ( 9 | -- * Typeclass 10 | HasPartialOrderConfigAddr (..), 11 | 12 | -- * Datum 13 | PartialOrderConfigDatum (..), 14 | PartialOrderConfigInfoF (..), 15 | PartialOrderConfigInfo, 16 | ) where 17 | 18 | import GHC.Generics (Generic) 19 | import GeniusYield.Scripts.Dex.PartialOrderConfig.Internal (PartialOrderConfigDatum (..)) 20 | import GeniusYield.Scripts.Dex.Version (POCVersion) 21 | import GeniusYield.Types 22 | import PlutusLedgerApi.V1 qualified as Plutus 23 | import PlutusTx ( 24 | BuiltinData, 25 | FromData (fromBuiltinData), 26 | ToData (toBuiltinData), 27 | ) 28 | 29 | class HasPartialOrderConfigAddr a where 30 | getPartialOrderConfigAddr ∷ a → POCVersion → GYAddress 31 | 32 | data PartialOrderConfigInfoF addr = PartialOrderConfigInfo 33 | { -- | Public key hashes of the potential signatories. 34 | pociSignatories ∷ ![GYPubKeyHash], 35 | -- | Number of required signatures. 36 | pociReqSignatories ∷ !Integer, 37 | -- | Minting Policy Id of the partial order Nft. 38 | pociNftSymbol ∷ !GYMintingPolicyId, 39 | -- | Address to which fees are paid. 40 | pociFeeAddr ∷ !addr, 41 | -- | Flat fee (in lovelace) paid by the maker. 42 | pociMakerFeeFlat ∷ !Integer, 43 | -- | Proportional fee (in the offered token) paid by the maker. 44 | pociMakerFeeRatio ∷ !GYRational, 45 | -- | Flat fee (in lovelace) paid by the taker. 46 | pociTakerFee ∷ !Integer, 47 | -- | Minimum required deposit (in lovelace). 48 | pociMinDeposit ∷ !Integer 49 | } 50 | deriving stock (Show, Generic, Functor) 51 | 52 | type PartialOrderConfigInfo = PartialOrderConfigInfoF GYAddress 53 | 54 | instance ToData (PartialOrderConfigInfoF Plutus.Address) where 55 | toBuiltinData ∷ PartialOrderConfigInfoF Plutus.Address → BuiltinData 56 | toBuiltinData PartialOrderConfigInfo {..} = 57 | toBuiltinData 58 | PartialOrderConfigDatum 59 | { pocdSignatories = pubKeyHashToPlutus <$> pociSignatories, 60 | pocdReqSignatories = pociReqSignatories, 61 | pocdNftSymbol = mintingPolicyIdToCurrencySymbol pociNftSymbol, 62 | pocdFeeAddr = pociFeeAddr, 63 | pocdMakerFeeFlat = pociMakerFeeFlat, 64 | pocdMakerFeeRatio = rationalToPlutus pociMakerFeeRatio, 65 | pocdTakerFee = pociTakerFee, 66 | pocdMinDeposit = pociMinDeposit 67 | } 68 | 69 | instance ToData PartialOrderConfigInfo where 70 | toBuiltinData ∷ PartialOrderConfigInfo → BuiltinData 71 | toBuiltinData = toBuiltinData . fmap addressToPlutus 72 | 73 | instance FromData (PartialOrderConfigInfoF Plutus.Address) where 74 | fromBuiltinData ∷ BuiltinData → Maybe (PartialOrderConfigInfoF Plutus.Address) 75 | fromBuiltinData d = do 76 | PartialOrderConfigDatum {..} ← fromBuiltinData d 77 | signatories ← fromEither $ mapM pubKeyHashFromPlutus pocdSignatories 78 | nftSymbol ← fromEither $ mintingPolicyIdFromCurrencySymbol pocdNftSymbol 79 | pure 80 | PartialOrderConfigInfo 81 | { pociSignatories = signatories, 82 | pociReqSignatories = pocdReqSignatories, 83 | pociNftSymbol = nftSymbol, 84 | pociFeeAddr = pocdFeeAddr, 85 | pociMakerFeeFlat = pocdMakerFeeFlat, 86 | pociMakerFeeRatio = rationalFromPlutus pocdMakerFeeRatio, 87 | pociTakerFee = pocdTakerFee, 88 | pociMinDeposit = pocdMinDeposit 89 | } 90 | where 91 | fromEither ∷ Either e a → Maybe a 92 | fromEither = either (const Nothing) Just 93 | -------------------------------------------------------------------------------- /geniusyield-dex-api/src/GeniusYield/Scripts/Dex/PartialOrderConfig/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | {- | 4 | Module : GeniusYield.Scripts.Dex.PartialOrderConfig.Internal 5 | Copyright : (c) 2023 GYELD GMBH 6 | License : Apache 2.0 7 | Maintainer : support@geniusyield.co 8 | Stability : develop 9 | -} 10 | module GeniusYield.Scripts.Dex.PartialOrderConfig.Internal ( 11 | PartialOrderConfigDatum (..), 12 | ) where 13 | 14 | import GHC.Generics (Generic) 15 | import PlutusLedgerApi.V1 (Address, PubKeyHash) 16 | import PlutusLedgerApi.V1.Value (CurrencySymbol (..)) 17 | import PlutusTx qualified 18 | import PlutusTx.Prelude (Integer) 19 | import PlutusTx.Ratio (Rational) 20 | import Prelude qualified as P 21 | 22 | data PartialOrderConfigDatum = PartialOrderConfigDatum 23 | { -- | Public key hashes of the potential signatories. 24 | pocdSignatories ∷ [PubKeyHash], 25 | -- | Number of required signatures. 26 | pocdReqSignatories ∷ Integer, 27 | -- | Currency symbol of the partial order Nft. 28 | pocdNftSymbol ∷ CurrencySymbol, 29 | -- | Address to which fees are paid. 30 | pocdFeeAddr ∷ Address, 31 | -- | Flat fee (in lovelace) paid by the maker. 32 | pocdMakerFeeFlat ∷ Integer, 33 | -- | Proportional fee (in the offered token) paid by the maker. 34 | pocdMakerFeeRatio ∷ Rational, 35 | -- | Flat fee (in lovelace) paid by the taker. 36 | pocdTakerFee ∷ Integer, 37 | -- | Minimum required deposit (in lovelace). 38 | pocdMinDeposit ∷ Integer 39 | } 40 | deriving (Generic, P.Show) 41 | 42 | PlutusTx.unstableMakeIsData ''PartialOrderConfigDatum 43 | -------------------------------------------------------------------------------- /geniusyield-dex-api/src/GeniusYield/Scripts/Dex/PartialOrderNft.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module : GeniusYield.Scripts.Dex.PartialOrderNft 3 | Copyright : (c) 2023 GYELD GMBH 4 | License : Apache 2.0 5 | Maintainer : support@geniusyield.co 6 | Stability : develop 7 | -} 8 | module GeniusYield.Scripts.Dex.PartialOrderNft ( 9 | -- * Typeclass 10 | HasPartialOrderNftScript (..), 11 | 12 | -- * Policy 13 | partialOrderNftMintingPolicy, 14 | ) where 15 | 16 | import GeniusYield.Scripts.Common 17 | import GeniusYield.Scripts.Dex.PartialOrder (HasPartialOrderScript, partialOrderValidator) 18 | import GeniusYield.Scripts.Dex.PartialOrderConfig (HasPartialOrderConfigAddr (getPartialOrderConfigAddr)) 19 | import GeniusYield.Scripts.Dex.Version (POCVersion) 20 | import GeniusYield.Types ( 21 | GYAssetClass, 22 | GYMintingPolicy, 23 | PlutusVersion (PlutusV2), 24 | addressToPlutus, 25 | assetClassToPlutus, 26 | scriptPlutusHash, 27 | validatorToScript, 28 | ) 29 | import PlutusLedgerApi.V1 (Address, ScriptHash) 30 | import PlutusLedgerApi.V1.Value (AssetClass) 31 | import Ply (ScriptRole (..), TypedScript, (#)) 32 | 33 | class HasPartialOrderNftScript a where 34 | getPartialOrderNftPolicy ∷ a → POCVersion → TypedScript 'MintingPolicyRole '[ScriptHash, Address, AssetClass] 35 | 36 | partialOrderNftMintingPolicy 37 | ∷ (HasPartialOrderNftScript a, HasPartialOrderScript a, HasPartialOrderConfigAddr a) 38 | ⇒ a 39 | → POCVersion 40 | → GYAssetClass 41 | → GYMintingPolicy 'PlutusV2 42 | partialOrderNftMintingPolicy a pocVersion ac = 43 | mintingPolicyFromPly $ 44 | getPartialOrderNftPolicy a pocVersion 45 | # scriptPlutusHash (validatorToScript v) 46 | # addressToPlutus (getPartialOrderConfigAddr a pocVersion) 47 | # assetClassToPlutus ac 48 | where 49 | v = partialOrderValidator a pocVersion ac 50 | -------------------------------------------------------------------------------- /geniusyield-dex-api/src/GeniusYield/Scripts/Dex/Version.hs: -------------------------------------------------------------------------------- 1 | module GeniusYield.Scripts.Dex.Version ( 2 | POCVersion (..), 3 | defaultPOCVersion, 4 | SingPOCVersion (..), 5 | toSingPOCVersion, 6 | fromSingPOCVersion, 7 | SingPOCVersionI (..), 8 | SomeSingPOCVersion (..), 9 | withSomeSingPOCVersion, 10 | ) where 11 | 12 | import Control.Lens ((?~)) 13 | import Data.Aeson (FromJSON, ToJSON) 14 | import Data.Aeson qualified as Aeson 15 | import Data.Default (Default (..)) 16 | import Data.GADT.Compare 17 | import Data.Swagger qualified as Swagger 18 | import Data.Swagger.Internal.Schema qualified as Swagger 19 | import Data.Type.Equality ((:~:) (..)) 20 | import GHC.Generics (Generic) 21 | import GeniusYield.Imports ((&)) 22 | 23 | {- | Version of the family of partial order contracts. 24 | 25 | >>> maxBound :: POCVersion 26 | POCVersion1_1 27 | -} 28 | data POCVersion = POCVersion1 | POCVersion1_1 29 | deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) 30 | deriving anyclass (FromJSON, ToJSON) 31 | 32 | instance Default POCVersion where 33 | def = maxBound 34 | 35 | -- | Same as @def@ but grep friendly. 36 | defaultPOCVersion ∷ POCVersion 37 | defaultPOCVersion = def 38 | 39 | instance Swagger.ToParamSchema POCVersion where 40 | toParamSchema _ = mempty & Swagger.type_ ?~ Swagger.SwaggerString & Swagger.enum_ ?~ map Aeson.toJSON [minBound ∷ POCVersion .. maxBound] 41 | 42 | instance Swagger.ToSchema POCVersion where 43 | declareNamedSchema p = 44 | pure $ 45 | Swagger.named "POCVersion" $ 46 | Swagger.paramSchemaToSchema p 47 | & Swagger.example 48 | ?~ Aeson.toJSON POCVersion1 49 | & Swagger.description 50 | ?~ "Version of the family of partial order contracts" 51 | 52 | data SingPOCVersion (v ∷ POCVersion) where 53 | SingPOCVersion1 ∷ SingPOCVersion 'POCVersion1 54 | SingPOCVersion1_1 ∷ SingPOCVersion 'POCVersion1_1 55 | 56 | data SomeSingPOCVersion where 57 | SomeSingPOCVersion ∷ SingPOCVersionI v ⇒ SingPOCVersion v → SomeSingPOCVersion 58 | 59 | toSingPOCVersion ∷ POCVersion → SomeSingPOCVersion 60 | toSingPOCVersion POCVersion1 = SomeSingPOCVersion SingPOCVersion1 61 | toSingPOCVersion POCVersion1_1 = SomeSingPOCVersion SingPOCVersion1_1 62 | 63 | fromSingPOCVersion ∷ SingPOCVersion v → POCVersion 64 | fromSingPOCVersion SingPOCVersion1 = POCVersion1 65 | fromSingPOCVersion SingPOCVersion1_1 = POCVersion1_1 66 | 67 | withSomeSingPOCVersion ∷ SomeSingPOCVersion → (∀ v. SingPOCVersionI v ⇒ SingPOCVersion v → r) → r 68 | withSomeSingPOCVersion (SomeSingPOCVersion s) f = f s 69 | 70 | class SingPOCVersionI (v ∷ POCVersion) where 71 | singPOCVersion ∷ SingPOCVersion v 72 | 73 | instance SingPOCVersionI 'POCVersion1 where 74 | singPOCVersion = SingPOCVersion1 75 | 76 | instance SingPOCVersionI 'POCVersion1_1 where 77 | singPOCVersion = SingPOCVersion1_1 78 | 79 | instance GEq SingPOCVersion where 80 | geq SingPOCVersion1 SingPOCVersion1 = Just Refl 81 | geq SingPOCVersion1 SingPOCVersion1_1 = Nothing 82 | geq SingPOCVersion1_1 SingPOCVersion1 = Nothing 83 | geq SingPOCVersion1_1 SingPOCVersion1_1 = Just Refl 84 | 85 | instance GCompare SingPOCVersion where 86 | gcompare SingPOCVersion1 SingPOCVersion1 = GEQ 87 | gcompare SingPOCVersion1 SingPOCVersion1_1 = GLT 88 | gcompare SingPOCVersion1_1 SingPOCVersion1 = GGT 89 | gcompare SingPOCVersion1_1 SingPOCVersion1_1 = GEQ 90 | -------------------------------------------------------------------------------- /geniusyield-onchain/LICENSE: -------------------------------------------------------------------------------- 1 | Business Source License 1.1 2 | 3 | License text copyright (c) 2023 MariaDB plc, All Rights Reserved. “Business Source License” is a trademark of MariaDB plc. 4 | 5 | ----------------------------------------------------------------------------- 6 | 7 | Parameters 8 | 9 | Licensor: GYELD LLC 10 | 11 | Licensed Work: GeniusYield Onchain Scripts 12 | The Licensed Work is (c) 2024 GYELD LLC 13 | 14 | Change Date: Four years from the date the Licensed 15 | Work is published 16 | 17 | Change License: GNU General Public License v2.0 or later 18 | 19 | ----------------------------------------------------------------------------- 20 | 21 | Terms 22 | 23 | The Licensor hereby grants you the right to copy, modify, create derivative works, redistribute, and make non-production use of the Licensed Work. The Licensor may make an Additional Use Grant, above, permitting limited production use. 24 | 25 | Effective on the Change Date, or the fourth anniversary of the first publicly available distribution of a specific version of the Licensed Work under this License, whichever comes first, the Licensor hereby grants you rights under the terms of the Change License, and the rights granted in the paragraph above terminate. 26 | 27 | If your use of the Licensed Work does not comply with the requirements currently in effect as described in this License, you must purchase a commercial license from the Licensor, its affiliated entities, or authorized resellers, or you must refrain from using the Licensed Work. 28 | 29 | All copies of the original and modified Licensed Work, and derivative works of the Licensed Work, are subject to this License. This License applies separately for each version of the Licensed Work and the Change Date may vary for each version of the Licensed Work released by Licensor. 30 | 31 | You must conspicuously display this License on each original or modified copy of the Licensed Work. If you receive the Licensed Work in original or modified form from a third party, the terms and conditions set forth in this License apply to your use of that work. 32 | 33 | Any use of the Licensed Work in violation of this License will automatically terminate your rights under this License for the current and all other versions of the Licensed Work. 34 | 35 | This License does not grant you any right in any trademark or logo of Licensor or its affiliates (provided that you may use a trademark or logo of Licensor as expressly required by this License).TO THE EXTENT PERMITTED BY APPLICABLE LAW, THE LICENSED WORK IS PROVIDED ON AN “AS IS” BASIS. LICENSOR HEREBY DISCLAIMS ALL WARRANTIES AND CONDITIONS, EXPRESS OR IMPLIED, INCLUDING (WITHOUT LIMITATION) WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, NON-INFRINGEMENT, AND TITLE. MariaDB hereby grants you permission to use this License’s text to license your works, and to refer to it using the trademark “Business Source License”, as long as you comply with the Covenants of Licensor below. 36 | 37 | ----------------------------------------------------------------------------- 38 | 39 | Covenants of Licensor 40 | 41 | In consideration of the right to use this License’s text and the “Business Source License” name and trademark, Licensor covenants to MariaDB, and to all other recipients of the licensed work to be provided by Licensor: 42 | 43 | To specify as the Change License the GPL Version 2.0 or any later version, or a license that is compatible with GPL Version 2.0 or a later version, where “compatible” means that software provided under the Change License can be included in a program with software provided under GPL Version 2.0 or a later version. Licensor may specify additional Change Licenses without limitation. 44 | To either: (a) specify an additional grant of rights to use that does not impose any additional restriction on the right granted in this License, as the Additional Use Grant; or (b) insert the text “None” to specify a Change Date. Not to modify this License in any other way. 45 | 46 | ----------------------------------------------------------------------------- 47 | 48 | Notice 49 | 50 | The Business Source License (this document, or the “License”) is not an Open Source license. However, the Licensed Work will eventually be made available under an Open Source License, as stated in this License. 51 | -------------------------------------------------------------------------------- /geniusyield-onchain/README.md: -------------------------------------------------------------------------------- 1 | # GeniusYield Onchain Smart Contracts 2 | 3 | * [DEX Contracts](./src/GeniusYield/OnChain/DEX/). 4 | 5 | -------------------------------------------------------------------------------- /geniusyield-onchain/app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Main where 5 | 6 | import Control.Exception (throwIO) 7 | import Control.Monad.IO.Class (liftIO) 8 | import Control.Monad.Trans.Except 9 | import Data.Text (Text) 10 | import qualified Data.Text as Txt 11 | import System.Directory (createDirectoryIfMissing) 12 | import System.FilePath (()) 13 | 14 | import Ply 15 | import Ply.Core.Internal.Reify (ReifyRole, 16 | ReifyTypenames) 17 | import Ply.Core.Serialize 18 | import Ply.Core.TypedReader 19 | 20 | import GeniusYield.OnChain.Common.Scripts 21 | 22 | import GeniusYield.OnChain.DEX.NFT.Compiled (optimizedNftPolicy) 23 | import GeniusYield.OnChain.DEX.PartialOrder.Compiled (optimizedPartialOrderValidator, 24 | optimizedPartialOrderValidatorWithTracing) 25 | import GeniusYield.OnChain.DEX.PartialOrderConfig.Compiled (optimizedPartialOrderConfigValidator, 26 | optimizedPartialOrderConfigValidatorWithTracing) 27 | import GeniusYield.OnChain.DEX.PartialOrderNFT.Compiled (optimizedPartialOrderNftPolicy, 28 | optimizedPartialOrderNftPolicyWithTracing) 29 | import GeniusYield.OnChain.DEX.PartialOrderNFTV1_1.Compiled 30 | 31 | main :: IO () 32 | main = do 33 | createDirectoryIfMissing False scriptStorage 34 | runExceptT writeScripts >>= \case 35 | Left e -> throwIO . userError $ Txt.unpack e 36 | Right a -> pure a 37 | 38 | writeScripts :: ExceptT Text IO () 39 | writeScripts = do 40 | writeScriptHelper dex'NFTFile optimizedNftPolicy 41 | writeScriptHelper dex'PartialOrderFile optimizedPartialOrderValidator 42 | writeScriptHelper dex'PartialOrderFileTracing optimizedPartialOrderValidatorWithTracing 43 | writeScriptHelper dex'PartialOrderNFTFile optimizedPartialOrderNftPolicy 44 | writeScriptHelper dex'PartialOrderNFTFileTracing optimizedPartialOrderNftPolicyWithTracing 45 | writeScriptHelper dex'PartialOrderNFTV1_1File optimizedPartialOrderNftV1_1Policy 46 | writeScriptHelper dex'PartialOrderNFTV1_1FileTracing optimizedPartialOrderNftV1_1PolicyWithTracing 47 | writeScriptHelper dex'PartialOrderConfigFile optimizedPartialOrderConfigValidator 48 | writeScriptHelper dex'PartialOrderConfigFileTracing optimizedPartialOrderConfigValidatorWithTracing 49 | 50 | scriptStorage :: FilePath 51 | scriptStorage = "geniusyield-common/data/compiled-scripts" 52 | 53 | writeScriptHelper :: (ReifyRole rl, ReifyTypenames params) => FilePath -> Either Text (TypedScript rl params) -> ExceptT Text IO () 54 | writeScriptHelper name script = except script 55 | >>= liftIO . writeEnvelope (scriptStorage name) . typedScriptToEnvelope (Txt.pack name) 56 | -------------------------------------------------------------------------------- /geniusyield-onchain/cabal.project: -------------------------------------------------------------------------------- 1 | repository cardano-haskell-packages 2 | url: https://input-output-hk.github.io/cardano-haskell-packages 3 | secure: True 4 | root-keys: 5 | 3e0cce471cf09815f930210f7827266fd09045445d65923e6d0238a6cd15126f 6 | 443abb7fb497a134c343faf52f0b659bd7999bc06b7f63fa76dc99d631f9bea1 7 | a86a1f6ce86c449c46666bda44268677abf29b5b2d2eb5ec7af903ec2f117a82 8 | bcec67e8e99cabfa7764d75ad9b158d72bfacf70ca1d0ec8bc6b4406d1bf8413 9 | c00aae8461a256275598500ea0e187588c35a5d5d7454fb57eac18d9edb86a56 10 | d4a35cd3121aa00d18544bb0ac01c3e1691d618f462c46129271bccf39f7e8ee 11 | 12 | index-state: 13 | , hackage.haskell.org 2022-11-14T00:20:02Z 14 | , cardano-haskell-packages 2022-11-17T04:56:26Z 15 | 16 | packages: . 17 | packages: geniusyield-common 18 | 19 | write-ghc-environment-files: never 20 | 21 | tests: true 22 | 23 | test-show-details: direct 24 | 25 | source-repository-package 26 | type: git 27 | --sha256: sha256-K4FNHQUpq4V0XkP1AUfnwFtOc2BMK007dv9aAgFStVs= 28 | location: https://github.com/Plutonomicon/plutarch-plutus.git 29 | tag: 95e40b42a1190191d0a07e3e4e938b72e6f75268 30 | subdir: 31 | . 32 | plutarch-extra 33 | 34 | source-repository-package 35 | type: git 36 | --sha256: sha256-wVFNBK6JOTKQX9Ov/SbEmN+ZA79HITQ/axLOmJUJV5o= 37 | location: https://github.com/well-typed/plutonomy 38 | tag: 14b9bd46084db1b785b3a99d55f7f10d38165ee8 39 | 40 | source-repository-package 41 | type: git 42 | location: https://github.com/mlabs-haskell/ply.git 43 | tag: b8cf54f57a3ec8543781f1b205544175f3341355 44 | --sha256: sha256-Fhvs1dCI9fHizJOHdqek7JmjifZHLVSutYAJR3IXNQE= 45 | subdir: 46 | ply-core 47 | ply-plutarch 48 | 49 | with-compiler: ghc-9.2.8 50 | 51 | constraints: 52 | dependent-sum >= 0.7.1.0 53 | 54 | package nothunks 55 | flags: +vector 56 | 57 | package plutonomy 58 | flags: +CHaP 59 | -------------------------------------------------------------------------------- /geniusyield-onchain/fixtures/nftpolicy-aggressive.txt: -------------------------------------------------------------------------------- 1 | let* fstPair!! = fstPair# ! ! 2 | sndPair!! = sndPair# ! ! 3 | equalsInteger_1 = equalsInteger# 1# 4 | chooseList!! = chooseList# ! ! 5 | ifThenElse! = ifThenElse# ! 6 | tailList! = tailList# ! 7 | headList! = headList# ! 8 | zComb = \ f -> let* x = \ y -> f (\ u -> y y u) in f (\ v -> x x v) 9 | x_0 = \ x_1 -> zComb (\ x_2 x_3 -> chooseList!! x_3 (\ ~ -> False#) (\ ~ -> ifThenElse! (x_1 (headList! x_3)) (\ ~ -> True#) (\ ~ -> x_2 (tailList! x_3)) !) !) 10 | x_4 = 11 | \ x_5 -> 12 | let* x_6 = bData# x_5 13 | in \ x_7 -> 14 | zComb 15 | (\ x_8 x_9 -> 16 | chooseList!! x_9 (\ ~ x_a x_b -> x_b !) (\ ~ -> ifThenElse! (equalsData# (fstPair!! (headList! x_9)) x_6) (\ ~ -> let* x_c = unMapData# (sndPair!! (headList! x_9)) in \ x_d x_e -> x_d x_c) (\ ~ -> x_8 (tailList! x_9)) !) !) 17 | x_7 18 | x_f = \ x_g -> tailList! (tailList! (tailList! (tailList! x_g))) 19 | x_h = \ x_i -> sndPair!! (unConstrData# x_i) 20 | x_j = \ x_k -> let* x_m = unConstrData# (headList! (tailList! (x_h x_k))); x_x = sndPair!! x_m in ifThenElse! (equalsInteger# 0# (fstPair!! x_m)) (\ ~ -> unBData# (headList! x_x)) (\ ~ -> ERROR) ! 21 | tt = ()# 22 | x_n = \ x_p x_r -> ifThenElse! x_p x_r (\ ~ -> False#) 23 | in \ x_s x_t -> 24 | let* x_u = unConstrData# x_s 25 | x_x_0 = sndPair!! x_u 26 | in ifThenElse! 27 | (equalsInteger_1 (fstPair!! x_u)) 28 | (\ ~ -> ifThenElse! (x_0 (\ x_v -> lessThanEqualsInteger# 0# (unIData# (sndPair!! x_v))) (x_4 (x_j x_t) (unMapData# (headList! (x_f (x_h (headList! (x_h x_t)))))) (\ x_w -> x_w) (\ ~ -> ERROR))) (\ ~ -> ERROR) (\ ~ -> tt) !) 29 | (\ ~ -> 30 | let* x_x = headList! (x_h x_t) 31 | headList!_x_x = headList! x_x_0 32 | x_headList!_x_x = x_h headList!_x_x 33 | x_y = sha2_256# (consByteString# (unIData# (headList! (tailList! x_headList!_x_x))) (unBData# (headList! (x_h (headList! x_headList!_x_x))))) 34 | x_z = x_4 (x_j x_t) (unMapData# (headList! (x_f (x_h x_x)))) (\ x_10 -> x_10) (\ ~ -> ERROR) 35 | in chooseList!! 36 | x_z 37 | (\ ~ -> ERROR) 38 | (\ ~ -> 39 | ifThenElse! 40 | (x_n 41 | (x_0 (\ x_11 -> equalsData# (listData# (x_h headList!_x_x)) (listData# (x_h (headList! (x_h x_11))))) (unListData# (headList! (x_h x_x)))) 42 | (\ ~ -> x_n (nullList# ! (tailList! x_z)) (\ ~ -> x_n (equalsInteger_1 (unIData# (sndPair!! (headList! x_z)))) (\ ~ -> equalsByteString# (unBData# (fstPair!! (headList! x_z))) x_y) !) !) 43 | !) 44 | (\ ~ -> tt) 45 | (\ ~ -> ERROR) 46 | !) 47 | !) 48 | ! 49 | -------------------------------------------------------------------------------- /geniusyield-onchain/fixtures/nftpolicy-optimized.txt: -------------------------------------------------------------------------------- 1 | let* fstPair!! = fstPair# ! ! 2 | sndPair!! = sndPair# ! ! 3 | equalsInteger_1 = equalsInteger# 1# 4 | chooseList!! = chooseList# ! ! 5 | ifThenElse! = ifThenElse# ! 6 | tailList! = tailList# ! 7 | headList! = headList# ! 8 | zComb = \ f -> let* x = \ y -> f (\ u -> y y u) in f (\ v -> x x v) 9 | x_0 = \ x_1 -> zComb (\ x_2 x_3 -> chooseList!! x_3 (\ ~ -> False#) (\ ~ -> ifThenElse! (x_1 (headList! x_3)) (\ ~ -> True#) (\ ~ -> x_2 (tailList! x_3)) !) !) 10 | x_4 = 11 | \ x_5 -> 12 | let* x_6 = bData# x_5 13 | in \ x_7 -> 14 | zComb 15 | (\ x_8 x_9 -> 16 | chooseList!! x_9 (\ ~ x_a x_b -> x_b !) (\ ~ -> ifThenElse! (equalsData# (fstPair!! (headList! x_9)) x_6) (\ ~ -> let* x_c = unMapData# (sndPair!! (headList! x_9)) in \ x_d x_e -> x_d x_c) (\ ~ -> x_8 (tailList! x_9)) !) !) 17 | x_7 18 | x_f = \ x_g -> tailList! (tailList! (tailList! (tailList! x_g))) 19 | x_h = \ x_i -> sndPair!! (unConstrData# x_i) 20 | x_j = \ x_k -> let* x_m = unConstrData# (headList! (tailList! (x_h x_k))); x_x = sndPair!! x_m in ifThenElse! (equalsInteger# 0# (fstPair!! x_m)) (\ ~ -> unBData# (headList! x_x)) (\ ~ -> ERROR) ! 21 | tt = ()# 22 | x_n = \ x_p x_r -> ifThenElse! x_p x_r (\ ~ -> False#) 23 | in \ x_s x_t -> 24 | let* x_u = unConstrData# x_s 25 | x_x_0 = sndPair!! x_u 26 | in ifThenElse! 27 | (equalsInteger_1 (fstPair!! x_u)) 28 | (\ ~ -> ifThenElse! (x_0 (\ x_v -> lessThanEqualsInteger# 0# (unIData# (sndPair!! x_v))) (x_4 (x_j x_t) (unMapData# (headList! (x_f (x_h (headList! (x_h x_t)))))) (\ x_w -> x_w) (\ ~ -> ERROR))) (\ ~ -> ERROR) (\ ~ -> tt) !) 29 | (\ ~ -> 30 | let* x_x = headList! (x_h x_t) 31 | headList!_x_x = headList! x_x_0 32 | x_headList!_x_x = x_h headList!_x_x 33 | x_y = sha2_256# (consByteString# (unIData# (headList! (tailList! x_headList!_x_x))) (unBData# (headList! (x_h (headList! x_headList!_x_x))))) 34 | x_z = x_4 (x_j x_t) (unMapData# (headList! (x_f (x_h x_x)))) (\ x_10 -> x_10) (\ ~ -> ERROR) 35 | in chooseList!! 36 | x_z 37 | (\ ~ -> ERROR) 38 | (\ ~ -> 39 | ifThenElse! 40 | (x_n 41 | (x_0 (\ x_11 -> equalsData# (listData# (x_h headList!_x_x)) (listData# (x_h (headList! (x_h x_11))))) (unListData# (headList! (x_h x_x)))) 42 | (\ ~ -> x_n (nullList# ! (tailList! x_z)) (\ ~ -> x_n (equalsInteger_1 (unIData# (sndPair!! (headList! x_z)))) (\ ~ -> equalsByteString# (unBData# (fstPair!! (headList! x_z))) x_y) !) !) 43 | !) 44 | (\ ~ -> tt) 45 | (\ ~ -> ERROR) 46 | !) 47 | !) 48 | ! 49 | -------------------------------------------------------------------------------- /geniusyield-onchain/fixtures/nftpolicy-original.txt: -------------------------------------------------------------------------------- 1 | let* x = fstPair# ! ! 2 | x_0 = sndPair# ! ! 3 | x_1 = \ x_2 -> x_0 (unConstrData# x_2) 4 | x_3 = headList# ! 5 | x_4 = tailList# ! 6 | x_5 = ifThenElse# ! 7 | x_6 = \ x_7 -> let* x_8 = unConstrData# (x_3 (x_4 (x_1 x_7))); x_9 = x x_8; x_a = x_0 x_8 in x_5 (equalsInteger# 0# x_9) (\ ~ -> unBData# (x_3 x_a)) (\ ~ -> ERROR) ! 8 | x_b = \ x_c -> x_4 (x_4 x_c) 9 | x_d = \ x_e -> x_4 (x_b x_e) 10 | x_f = \ x_g -> x_4 (x_d x_g) 11 | x_h = \ x_i -> let* x_j = unMapData# (x_0 x_i) in \ x_k x_m -> x_k x_j 12 | x_n = chooseList# ! ! 13 | x_p = \ x_r -> let* x_s = \ x_t -> x_r (\ x_u -> x_t x_t x_u) in x_r (\ x_v -> x_s x_s x_v) 14 | x_w = \ x_x x_y x_z -> x_p (\ x_10 x_11 -> x_n x_11 (\ ~ x_12 x_13 -> x_13 !) (\ ~ -> x_5 (equalsData# (x (x_3 x_11)) x_y) (\ ~ -> x_x (x_3 x_11)) (\ ~ -> x_10 (x_4 x_11)) !) !) x_z 15 | x_14 = \ x_15 -> x_w x_h (bData# x_15) 16 | x_16 = \ ~ -> False# 17 | x_17 = \ x_18 x_19 -> x_5 x_18 x_19 x_16 18 | x_1a = \ ~ -> True# 19 | x_1b = \ x_1c -> x_5 x_1c x_1a 20 | x_1d = \ x_1e -> x_p (\ x_1f x_1g -> x_n x_1g (\ ~ -> False#) (\ ~ -> x_1b (x_1e (x_3 x_1g)) (\ ~ -> x_1f (x_4 x_1g)) !) !) 21 | in \ x_1h x_1i -> 22 | let* x_1j = unConstrData# x_1h 23 | x_1k = x x_1j 24 | x_1m = x_0 x_1j 25 | in x_5 26 | (equalsInteger# 1# x_1k) 27 | (\ ~ -> let* x_1n = x_6 x_1i; x_1p = x_3 (x_1 x_1i) in x_5 (x_1d (\ x_1r -> lessThanEqualsInteger# 0# (unIData# (x_0 x_1r))) (x_14 x_1n (unMapData# (x_3 (x_f (x_1 x_1p)))) (\ x_1s -> x_1s) (\ ~ -> ERROR))) (\ ~ -> ERROR) (\ ~ -> ()#) !) 28 | (\ ~ -> 29 | let* x_1t = x_3 (x_1 x_1i) 30 | x_1u = x_3 x_1m 31 | x_1v = x_1 x_1u 32 | x_1w = sha2_256# (consByteString# (unIData# (x_3 (x_4 x_1v))) (let* x_1x = x_3 x_1v in unBData# (x_3 (x_1 x_1x)))) 33 | x_1y = x_6 x_1i 34 | x_1z = x_14 x_1y (unMapData# (x_3 (x_f (x_1 x_1t)))) (\ x_20 -> x_20) (\ ~ -> ERROR) 35 | in x_n 36 | x_1z 37 | (\ ~ -> ERROR) 38 | (\ ~ -> 39 | x_5 40 | (x_17 41 | (let* x_21 = unListData# (x_3 (x_1 x_1t)) 42 | in x_1d (\ x_22 -> let* x_23 = x_3 (x_1 x_22) in equalsData# (listData# (x_1 x_1u)) (listData# (x_1 x_23))) x_21) 43 | (\ ~ -> x_17 (nullList# ! (x_4 x_1z)) (\ ~ -> x_17 (equalsInteger# (unIData# (x_0 (x_3 x_1z))) 1#) (\ ~ -> equalsByteString# (unBData# (x (x_3 x_1z))) x_1w) !) !) 44 | !) 45 | (\ ~ -> ()#) 46 | (\ ~ -> ERROR) 47 | !) 48 | !) 49 | ! 50 | -------------------------------------------------------------------------------- /geniusyield-onchain/flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "geniusyield-onchain"; 3 | 4 | inputs = { 5 | haskellNix.url = "github:input-output-hk/haskell.nix"; 6 | nixpkgs.follows = "haskellNix/nixpkgs-unstable"; 7 | flake-utils.url = "github:numtide/flake-utils"; 8 | CHaP = { 9 | url = "github:input-output-hk/cardano-haskell-packages?ref=repo"; 10 | flake = false; 11 | }; 12 | }; 13 | 14 | outputs = { self, nixpkgs, flake-utils, haskellNix, CHaP }: 15 | flake-utils.lib.eachSystem [ "x86_64-linux" ] (system: 16 | let 17 | pkgs = import nixpkgs { 18 | inherit system; 19 | overlays = [ 20 | haskellNix.overlay 21 | ]; 22 | inherit (haskellNix) config; 23 | }; 24 | onchain = pkgs.haskell-nix.cabalProject' { 25 | src = ./.; 26 | compiler-nix-name = "ghc925"; 27 | shell = { 28 | # This is used by `nix develop .` to open a shell for use with 29 | # `cabal`, `hlint` and `haskell-language-server` etc 30 | tools = { 31 | cabal = "3.8.1.0"; 32 | haskell-language-server = { 33 | version = "1.8.0.0"; 34 | index-state = "2022-10-31T00:00:00Z"; 35 | }; 36 | hlint = "3.5"; 37 | }; 38 | # Non-Haskell shell tools go here 39 | buildInputs = with pkgs; [ 40 | git 41 | ]; 42 | }; 43 | 44 | inputMap = { "https://input-output-hk.github.io/cardano-haskell-packages" = CHaP; }; 45 | }; 46 | in onchain.flake { }); 47 | } 48 | -------------------------------------------------------------------------------- /geniusyield-onchain/geniusyield-common/data/compiled-scripts/DEX.NFT: -------------------------------------------------------------------------------- 1 | { 2 | "cborHex": "59018a590187010000323232323232323232323232323232223232533300f301130130021533300f3300b23371290001bad3013001333300a30070033756601a60126010601a601000640022c2c200c26464646464a66602a0022c2a666028a6601466020466ebcdd398070029ba7300e3013300e00137586024601a00a2a660146ae8cc04c00454cc028c058dd6980b9809000899b8f375c6030602400200420162c666601c601600e6eacc044c034c030010800458dc919b8b375a602060220026eb8c040c02cc040004c028004c038008c034c02000cc044004dd5001111998060010008a504988c8c94ccc02ccdc3a4000601e00426eb8c02400458c034004dd5180398041801000918059baa0012300630063006300600123223300522533300b00112250011533300a3375e601c60100020082644460040066eacc034c0200044c008c024004004dd4800918011129998040008a50153330073003300500114a226004600c002464600446600400400246004466004004002ae855d12b9a5573e6e1d20025573caae741", 3 | "description": "DEX.NFT", 4 | "params": [], 5 | "rawHex": "590187010000323232323232323232323232323232223232533300f301130130021533300f3300b23371290001bad3013001333300a30070033756601a60126010601a601000640022c2c200c26464646464a66602a0022c2a666028a6601466020466ebcdd398070029ba7300e3013300e00137586024601a00a2a660146ae8cc04c00454cc028c058dd6980b9809000899b8f375c6030602400200420162c666601c601600e6eacc044c034c030010800458dc919b8b375a602060220026eb8c040c02cc040004c028004c038008c034c02000cc044004dd5001111998060010008a504988c8c94ccc02ccdc3a4000601e00426eb8c02400458c034004dd5180398041801000918059baa0012300630063006300600123223300522533300b00112250011533300a3375e601c60100020082644460040066eacc034c0200044c008c024004004dd4800918011129998040008a50153330073003300500114a226004600c002464600446600400400246004466004004002ae855d12b9a5573e6e1d20025573caae741", 6 | "role": "MintingPolicyRole", 7 | "type": "PlutusScriptV2", 8 | "version": "ScriptV2" 9 | } -------------------------------------------------------------------------------- /geniusyield-onchain/geniusyield-common/geniusyield-common.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: geniusyield-common 3 | version: 0.1.0.0 4 | synopsis: Common code shared between GeniusYield onchain and offchain 5 | license: Apache-2.0 6 | license-file: LICENSE 7 | author: GeniusYield 8 | maintainer: support@geniusyield.co 9 | build-type: Simple 10 | copyright: 2023 GYELD GMBH 11 | data-dir: data 12 | data-files: 13 | compiled-scripts/DEX.NFT 14 | compiled-scripts/DEX.PartialOrder 15 | compiled-scripts/DEX.PartialOrderConfig 16 | compiled-scripts/DEX.PartialOrderConfigTracing 17 | compiled-scripts/DEX.PartialOrderNFT 18 | compiled-scripts/DEX.PartialOrderNFTTracing 19 | compiled-scripts/DEX.PartialOrderNFTV1_1 20 | compiled-scripts/DEX.PartialOrderNFTV1_1Tracing 21 | compiled-scripts/DEX.PartialOrderTracing 22 | 23 | library 24 | default-language: GHC2021 25 | default-extensions: 26 | DataKinds 27 | DeriveAnyClass 28 | DerivingStrategies 29 | DerivingVia 30 | GADTs 31 | LambdaCase 32 | MultiWayIf 33 | OverloadedStrings 34 | RecordWildCards 35 | RoleAnnotations 36 | TemplateHaskell 37 | TypeFamilies 38 | UndecidableInstances 39 | UnicodeSyntax 40 | ViewPatterns 41 | 42 | ghc-options: -Wall 43 | hs-source-dirs: src 44 | exposed-modules: 45 | GeniusYield.OnChain.Common.Scripts 46 | GeniusYield.OnChain.Common.Scripts.DEX.Data 47 | 48 | build-depends: 49 | , aeson 50 | , base <5 51 | , bytestring 52 | , file-embed 53 | , plutus-ledger-api 54 | , ply-core 55 | , text 56 | -------------------------------------------------------------------------------- /geniusyield-onchain/geniusyield-common/src/GeniusYield/OnChain/Common/Scripts.hs: -------------------------------------------------------------------------------- 1 | module GeniusYield.OnChain.Common.Scripts 2 | ( dex'NFTFile 3 | , dex'PartialOrderFile 4 | , dex'PartialOrderFileTracing 5 | , dex'PartialOrderNFTFile 6 | , dex'PartialOrderNFTFileTracing 7 | , dex'PartialOrderNFTV1_1File 8 | , dex'PartialOrderNFTV1_1FileTracing 9 | , dex'PartialOrderConfigFile 10 | , dex'PartialOrderConfigFileTracing 11 | ) where 12 | 13 | dex'NFTFile :: FilePath 14 | dex'NFTFile = "DEX.NFT" 15 | 16 | dex'PartialOrderFile :: FilePath 17 | dex'PartialOrderFile = "DEX.PartialOrder" 18 | 19 | dex'PartialOrderFileTracing :: FilePath 20 | dex'PartialOrderFileTracing = "DEX.PartialOrderTracing" 21 | 22 | dex'PartialOrderNFTFile :: FilePath 23 | dex'PartialOrderNFTFile = "DEX.PartialOrderNFT" 24 | 25 | dex'PartialOrderNFTFileTracing :: FilePath 26 | dex'PartialOrderNFTFileTracing = "DEX.PartialOrderNFTTracing" 27 | 28 | dex'PartialOrderNFTV1_1File :: FilePath 29 | dex'PartialOrderNFTV1_1File = "DEX.PartialOrderNFTV1_1" 30 | 31 | dex'PartialOrderNFTV1_1FileTracing :: FilePath 32 | dex'PartialOrderNFTV1_1FileTracing = "DEX.PartialOrderNFTV1_1Tracing" 33 | 34 | dex'PartialOrderConfigFile :: FilePath 35 | dex'PartialOrderConfigFile = "DEX.PartialOrderConfig" 36 | 37 | dex'PartialOrderConfigFileTracing :: FilePath 38 | dex'PartialOrderConfigFileTracing = "DEX.PartialOrderConfigTracing" -------------------------------------------------------------------------------- /geniusyield-onchain/geniusyield-common/src/GeniusYield/OnChain/Common/Scripts/DEX/Data.hs: -------------------------------------------------------------------------------- 1 | module GeniusYield.OnChain.Common.Scripts.DEX.Data ( 2 | orderValidator, 3 | nftPolicyV1, 4 | nftPolicyV1_1, 5 | ) where 6 | 7 | import Data.Aeson qualified as Aeson 8 | import Data.ByteString (ByteString) 9 | import Data.FileEmbed 10 | import PlutusLedgerApi.V1 (Address) 11 | import PlutusLedgerApi.V1.Scripts (ScriptHash) 12 | import PlutusLedgerApi.V1.Value (AssetClass) 13 | import Ply ( 14 | ScriptRole (..), 15 | TypedScript, 16 | ) 17 | import Ply.Core.Internal.Reify (ReifyRole, ReifyTypenames) 18 | import Ply.Core.TypedReader (mkTypedScript) 19 | 20 | readScript ∷ ∀ r l. (ReifyRole r, ReifyTypenames l) ⇒ ByteString → TypedScript r l 21 | readScript bs = 22 | let envelope = either (error "GeniusYield.OnChain.Common.Scripts.DEX.Data.readScript: Failed to read envelope") id $ Aeson.eitherDecodeStrict' bs 23 | in either (error "GeniusYield.OnChain.Common.Scripts.DEX.Data.readScript: Failed to create typed script") id $ mkTypedScript @r @l envelope 24 | 25 | orderValidator ∷ (TypedScript 'ValidatorRole '[Address, AssetClass]) 26 | orderValidator = 27 | let fileBS = $(makeRelativeToProject "./data/compiled-scripts/DEX.PartialOrder" >>= embedFile) 28 | in readScript fileBS 29 | 30 | nftPolicyV1 ∷ (TypedScript 'MintingPolicyRole '[ScriptHash, Address, AssetClass]) 31 | nftPolicyV1 = 32 | let fileBS = $(makeRelativeToProject "./data/compiled-scripts/DEX.PartialOrderNFT" >>= embedFile) 33 | in readScript fileBS 34 | 35 | nftPolicyV1_1 ∷ (TypedScript 'MintingPolicyRole '[ScriptHash, Address, AssetClass]) 36 | nftPolicyV1_1 = 37 | let fileBS = $(makeRelativeToProject "./data/compiled-scripts/DEX.PartialOrderNFTV1_1" >>= embedFile) 38 | in readScript fileBS -------------------------------------------------------------------------------- /geniusyield-onchain/geniusyield-onchain.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: geniusyield-onchain 3 | version: 0.1.0.0 4 | synopsis: GeniusYield onchain code 5 | license: Apache-2.0 6 | license-file: LICENSE 7 | author: GeniusYield 8 | maintainer: support@geniusyield.co 9 | build-type: Simple 10 | copyright: 2023 GYELD GMBH 11 | 12 | common lang 13 | default-language: GHC2021 14 | default-extensions: 15 | DataKinds 16 | DeriveAnyClass 17 | DerivingStrategies 18 | TypeFamilies 19 | 20 | library 21 | import: lang 22 | ghc-options: -Wall 23 | 24 | -- so unfoldings are present even when compiled without optmizations 25 | ghc-options: 26 | -fno-ignore-interface-pragmas -fno-omit-interface-pragmas 27 | -Wno-partial-type-signatures 28 | 29 | -- expose all unfoldings, so plutustx compiler can do its job 30 | ghc-options: -fexpose-all-unfoldings -fobject-code 31 | hs-source-dirs: src 32 | exposed-modules: 33 | GeniusYield.OnChain.DEX.NFT 34 | GeniusYield.OnChain.DEX.NFT.Compiled 35 | GeniusYield.OnChain.DEX.PartialOrder 36 | GeniusYield.OnChain.DEX.PartialOrder.Compiled 37 | GeniusYield.OnChain.DEX.PartialOrder.Types 38 | GeniusYield.OnChain.DEX.PartialOrderConfig 39 | GeniusYield.OnChain.DEX.PartialOrderConfig.Compiled 40 | GeniusYield.OnChain.DEX.PartialOrderNFT 41 | GeniusYield.OnChain.DEX.PartialOrderNFT.Compiled 42 | GeniusYield.OnChain.DEX.PartialOrderNFTV1_1 43 | GeniusYield.OnChain.DEX.PartialOrderNFTV1_1.Compiled 44 | GeniusYield.OnChain.DEX.Utils 45 | GeniusYield.OnChain.Plutarch.Api 46 | GeniusYield.OnChain.Plutarch.Crypto 47 | GeniusYield.OnChain.Plutarch.Run 48 | GeniusYield.OnChain.Plutarch.Time 49 | GeniusYield.OnChain.Plutarch.Tx 50 | GeniusYield.OnChain.Plutarch.Types 51 | GeniusYield.OnChain.Plutarch.Utils 52 | GeniusYield.OnChain.Plutarch.Value 53 | GeniusYield.OnChain.Utils 54 | GeniusYield.Plutonomy 55 | 56 | build-depends: 57 | , base <5 58 | , bytestring 59 | , data-default 60 | , geniusyield-common 61 | , lens 62 | , plutarch 63 | , plutarch-extra 64 | , plutonomy 65 | , plutus-core 66 | , plutus-ledger-api 67 | , plutus-tx 68 | , plutus-tx-plugin 69 | , ply-core 70 | , ply-plutarch 71 | , text 72 | 73 | executable geniusyield-onchain-compiler 74 | import: lang 75 | ghc-options: -Wall -fwarn-incomplete-uni-patterns 76 | 77 | -- so unfoldings are present even when compiled without optmizations 78 | ghc-options: 79 | -fno-ignore-interface-pragmas -fno-omit-interface-pragmas 80 | -Wno-partial-type-signatures 81 | 82 | ghc-options: 83 | -O2 -threaded -rtsopts -with-rtsopts=-T -fplugin-opt 84 | PlutusTx.Plugin:defer-errors 85 | 86 | hs-source-dirs: app 87 | main-is: Main.hs 88 | build-depends: 89 | , base 90 | , directory 91 | , filepath 92 | , geniusyield-common 93 | , geniusyield-onchain 94 | , ply-core 95 | , text 96 | , transformers 97 | 98 | test-suite geniusyield-onchain-tests 99 | import: lang 100 | type: exitcode-stdio-1.0 101 | main-is: geniusyield-onchain-tests.hs 102 | hs-source-dirs: tests 103 | ghc-options: -threaded -rtsopts 104 | ghc-options: 105 | -Wall -Wincomplete-uni-patterns -Wno-unticked-promoted-constructors 106 | 107 | build-depends: 108 | , base 109 | , data-default 110 | , geniusyield-onchain 111 | , plutonomy 112 | , plutus-ledger-api 113 | , plutus-tx 114 | , ply-core 115 | , ply-plutarch 116 | , tasty 117 | , text 118 | -------------------------------------------------------------------------------- /geniusyield-onchain/src/GeniusYield/OnChain/DEX/Anastasia_Labs____Genius_Yield_Audit.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/geniusyield/dex-contracts-api/bb81fc95bfa5132bc4bb18db2cd182221eccf1b4/geniusyield-onchain/src/GeniusYield/OnChain/DEX/Anastasia_Labs____Genius_Yield_Audit.pdf -------------------------------------------------------------------------------- /geniusyield-onchain/src/GeniusYield/OnChain/DEX/NFT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# OPTIONS_GHC -O2 -fspecialize-aggressively #-} 7 | 8 | module GeniusYield.OnChain.DEX.NFT (mkNFTPolicy) where 9 | 10 | import Prelude (($), (.)) 11 | 12 | import Plutarch.Api.V1 13 | import qualified Plutarch.Api.V1.AssocMap as PMap 14 | import Plutarch.Prelude 15 | 16 | import GeniusYield.OnChain.Plutarch.Api 17 | import qualified Plutarch.Api.V2 as PV2 18 | 19 | mkNFTPolicy :: 20 | Term s (PAsData (PMaybeData PTxOutRef) 21 | :--> PV2.PScriptContext 22 | :--> PUnit 23 | ) 24 | mkNFTPolicy = plam $ \mtxOutRef ctx -> policy (pfromData mtxOutRef) ctx 25 | where 26 | policy :: 27 | Term s (PMaybeData PTxOutRef) 28 | -> Term s PV2.PScriptContext 29 | -> Term s PUnit 30 | 31 | policy txOutRef ctx = pmatch txOutRef 32 | $ \case 33 | PDNothing _ -> checkIfBurning # (pownSymbol # ctx) 34 | # pfromData (pfield @"txInfo" # ctx) 35 | 36 | PDJust rec -> plet (pfield @"txInfo" # ctx) $ \info 37 | -> plet (pfield @"_0" # rec) $ \ref 38 | -> validateMinting # 39 | ref # 40 | (pexpectedTokenName # ref) # 41 | info # 42 | (mintedTokens_ # (pownSymbol # ctx) # info) 43 | 44 | validateMinting :: 45 | Term s (PTxOutRef 46 | :--> PTokenName 47 | :--> PV2.PTxInfo 48 | :--> PMap any PTokenName PInteger 49 | :--> PUnit 50 | ) 51 | validateMinting = plam $ 52 | \txOutRef tn info -> 53 | let 54 | hasUtxoConsumed = putxoConsumed # txOutRef # (pfield @"inputs" # info) 55 | mintedTnAmt x = pfromData (psndBuiltin # x) 56 | mintedTnName x = pfromData (pfstBuiltin # x) 57 | errMsg = "Expected: 1.) UTxO consumption. 2.) Minted Amount should be 1. 3.) Valid Token name." 58 | in 59 | pelimList (\h t -> pif 60 | ( hasUtxoConsumed 61 | #&& pnull # t 62 | #&& mintedTnAmt h #== 1 63 | #&& mintedTnName h #== tn 64 | ) 65 | (pconstant ()) 66 | (ptraceError errMsg) 67 | ) (ptraceError "minted tokens list should not be empty.") . pto 68 | 69 | checkIfBurning :: 70 | Term s (PCurrencySymbol 71 | :--> PV2.PTxInfo 72 | :--> PUnit 73 | ) 74 | checkIfBurning = plam $ 75 | \cs info -> pif 76 | (pany # 77 | plam (\v -> 0 #<= pfromData (psndBuiltin # v)) # 78 | pto (mintedTokens_ # cs # info) 79 | ) 80 | (ptraceError "expected only burning") 81 | (pconstant ()) 82 | 83 | mintedTokens_ :: 84 | Term s (PCurrencySymbol 85 | :--> PV2.PTxInfo 86 | :--> PMap 'Sorted PTokenName PInteger 87 | ) 88 | mintedTokens_ = plam $ 89 | \cs info -> 90 | pmatch (PMap.plookup # cs # pto (pfromData $ pfield @"mint" # info)) $ 91 | \case 92 | PNothing -> perror 93 | PJust m -> m 94 | -------------------------------------------------------------------------------- /geniusyield-onchain/src/GeniusYield/OnChain/DEX/NFT/Compiled.hs: -------------------------------------------------------------------------------- 1 | module GeniusYield.OnChain.DEX.NFT.Compiled ( 2 | originalNftPolicy, 3 | optimizedNftPolicy 4 | ) where 5 | 6 | 7 | import Data.Text (Text) 8 | import Data.Default (def) 9 | 10 | import qualified Plutarch.Unsafe as PUNSAFE 11 | import Plutarch.Prelude 12 | import Ply hiding ((#)) 13 | import Ply.Plutarch 14 | import qualified Plutarch.Api.V2 as PV2 15 | import qualified Plutonomy 16 | 17 | import GeniusYield.OnChain.DEX.NFT 18 | import GeniusYield.Plutonomy () 19 | 20 | originalNftPolicy :: Either Text (TypedScript 'MintingPolicyRole '[]) 21 | originalNftPolicy = toTypedScript def mkNFTPolicy' 22 | 23 | optimizedNftPolicy :: Either Text (TypedScript 'MintingPolicyRole '[]) 24 | optimizedNftPolicy = Plutonomy.optimizeUPLC <$> originalNftPolicy 25 | 26 | mkNFTPolicy' :: ClosedTerm PV2.PMintingPolicy 27 | mkNFTPolicy' = plam $ \redm ctx -> 28 | popaque $ mkNFTPolicy 29 | # PUNSAFE.punsafeCoerce redm 30 | # ctx 31 | 32 | -------------------------------------------------------------------------------- /geniusyield-onchain/src/GeniusYield/OnChain/DEX/PartialOrder/Compiled.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module GeniusYield.OnChain.DEX.PartialOrder.Compiled ( 4 | originalPartialOrderValidator, 5 | optimizedPartialOrderValidator, 6 | optimizedPartialOrderValidatorWithTracing, 7 | ) where 8 | 9 | import PlutusLedgerApi.V1 10 | import PlutusLedgerApi.V1.Value (AssetClass) 11 | 12 | import Data.Default (def) 13 | import Data.Text (Text) 14 | import GeniusYield.OnChain.DEX.PartialOrder 15 | import Plutarch 16 | import Plutarch.Api.V1 17 | import qualified Plutarch.Api.V2 as PV2 18 | import qualified Plutarch.Unsafe as PUNSAFE 19 | import qualified Plutonomy 20 | import Ply hiding ((#)) 21 | import Ply.Plutarch 22 | 23 | import GeniusYield.OnChain.Plutarch.Api (PAssetClass) 24 | import GeniusYield.OnChain.Utils (desiredTracingMode) 25 | import GeniusYield.Plutonomy () 26 | 27 | originalPartialOrderValidator :: Config -> Either Text (TypedScript 'ValidatorRole '[Address, AssetClass]) 28 | originalPartialOrderValidator cnf = toTypedScript cnf mkPartialOrderValidator' 29 | 30 | optimizedPartialOrderValidator :: Either 31 | Text 32 | (TypedScript 'ValidatorRole '[Address, AssetClass]) 33 | optimizedPartialOrderValidator = Plutonomy.optimizeUPLC <$> originalPartialOrderValidator def 34 | 35 | optimizedPartialOrderValidatorWithTracing :: Either 36 | Text 37 | (TypedScript 'ValidatorRole '[Address, AssetClass]) 38 | optimizedPartialOrderValidatorWithTracing = Plutonomy.optimizeUPLC <$> originalPartialOrderValidator def {tracingMode = desiredTracingMode} 39 | 40 | mkPartialOrderValidator' :: 41 | ClosedTerm ( PAddress 42 | :--> PAssetClass 43 | :--> PV2.PValidator 44 | ) 45 | mkPartialOrderValidator' = plam $ \refInputAddr refInputToken datm redm ctx -> 46 | popaque $ mkPartialOrderValidator 47 | # refInputAddr 48 | # refInputToken 49 | # PUNSAFE.punsafeCoerce datm 50 | # PUNSAFE.punsafeCoerce redm 51 | # ctx 52 | -------------------------------------------------------------------------------- /geniusyield-onchain/src/GeniusYield/OnChain/DEX/PartialOrder/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DerivingVia #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | 13 | module GeniusYield.OnChain.DEX.PartialOrder.Types 14 | ( PMaybePPOSIXTimeData (..) 15 | , PPartialOrderFeeOutput (..) 16 | , PPartialOrderContainedFee (..) 17 | , PPartialOrderConfigDatum (..) 18 | , PPartialOrderDatum (..) 19 | , PPartialOrderAction (..) 20 | , type PHasType 21 | , type PartialOrderFeeOutputRec 22 | , type PartialOrderContainedFeeRec 23 | , type PartialOrderConfigRec 24 | , type PartialOrderRec 25 | ) where 26 | 27 | import GHC.TypeLits 28 | import Plutarch 29 | import Plutarch.Api.V1 30 | import Plutarch.DataRepr 31 | import Plutarch.DataRepr.Internal 32 | import Plutarch.DataRepr.Internal.HList.Utils 33 | import Plutarch.Extra.RationalData 34 | import Plutarch.Prelude 35 | 36 | import GeniusYield.OnChain.Plutarch.Types 37 | 38 | -- $setup 39 | -- >>> :set -XDataKinds 40 | -- >>> import GeniusYield.OnChain.Plutarch.Run 41 | -- >>> import Plutarch.Prelude 42 | 43 | type PHasType l a fs = 44 | (PUnLabel (IndexList (PLabelIndex l fs) fs) ~ a, KnownSymbol l, KnownNat (PLabelIndex l fs)) 45 | 46 | type PartialOrderFeeOutputRec 47 | = '[ "pofdMentionedFees" ':= PMap 'Unsorted PTxOutRef (PValue 'Sorted 'Positive) 48 | , "pofdReservedValue" ':= PValue 'Sorted 'Positive 49 | , "pofdSpentUTxORef" ':= PMaybeData PTxOutRef -- Here we don't require @PAsData@ wrapper to get @PTryFrom@ instance, i.e., we don't need to put @PMaybeData (PAsData PTxOutRef)@ unlike for @PPOSIXTime@. 50 | ] 51 | 52 | newtype PPartialOrderFeeOutput (s :: S) 53 | = PPartialOrderFeeOutput (Term s (PDataRecord PartialOrderFeeOutputRec)) 54 | deriving stock (Generic) 55 | deriving anyclass (PlutusType, PIsData, PEq, PDataFields, PTryFrom PData) 56 | 57 | instance DerivePlutusType PPartialOrderFeeOutput where type DPTStrat _ = PlutusTypeData 58 | 59 | instance PTryFrom PData (PAsData PPartialOrderFeeOutput) 60 | 61 | type PartialOrderContainedFeeRec 62 | = '[ "pocfLovelaces" ':= PInteger 63 | , "pocfOfferedTokens" ':= PInteger 64 | , "pocfAskedTokens" ':= PInteger 65 | ] 66 | 67 | newtype PPartialOrderContainedFee (s :: S) 68 | = PPartialOrderContainedFee (Term s (PDataRecord PartialOrderContainedFeeRec)) 69 | deriving stock (Generic) 70 | deriving anyclass (PlutusType, PIsData, PEq, PPartialOrd, PDataFields, PTryFrom PData) 71 | 72 | instance DerivePlutusType PPartialOrderContainedFee where type DPTStrat _ = PlutusTypeData 73 | 74 | instance PTryFrom PData (PAsData PPartialOrderContainedFee) 75 | 76 | -- | 77 | -- >>> :{ 78 | -- let a = 79 | -- pcon $ PPartialOrderContainedFee 80 | -- $ pdcons @"pocfLovelaces" # pdata 1 81 | -- #$ pdcons @"pocfOfferedTokens" # pdata 2 82 | -- #$ pdcons @"pocfAskedTokens" # pdata 3 83 | -- #$ pdnil 84 | -- b = 85 | -- pcon $ PPartialOrderContainedFee 86 | -- $ pdcons @"pocfLovelaces" # pdata 2 87 | -- #$ pdcons @"pocfOfferedTokens" # pdata 1 88 | -- #$ pdcons @"pocfAskedTokens" # pdata 0 89 | -- #$ pdnil 90 | -- in (evalT $ a <> b, evalT $ b <> mempty) 91 | -- :} 92 | -- (Right (Script {unScript = Program {_progAnn = (), _progVer = Version () 1 0 0, _progTerm = Constant () (Some (ValueOf DefaultUniData (Constr 0 [I 3,I 3,I 3])))}},ExBudget {exBudgetCPU = ExCPU 6087009, exBudgetMemory = ExMemory 17418},[]),Right (Script {unScript = Program {_progAnn = (), _progVer = Version () 1 0 0, _progTerm = Constant () (Some (ValueOf DefaultUniData (Constr 0 [I 2,I 1,I 0])))}},ExBudget {exBudgetCPU = ExCPU 6062009, exBudgetMemory = ExMemory 17254},[])) 93 | 94 | instance Semigroup (Term s PPartialOrderContainedFee) where 95 | a <> b = 96 | pletFields @["pocfLovelaces", "pocfOfferedTokens", "pocfAskedTokens"] a $ \a' -> 97 | pletFields @["pocfLovelaces", "pocfOfferedTokens", "pocfAskedTokens"] b $ \b' -> 98 | pcon $ PPartialOrderContainedFee 99 | $ pdcons @"pocfLovelaces" # pdata (getField @"pocfLovelaces" a' + getField @"pocfLovelaces" b') 100 | #$ pdcons @"pocfOfferedTokens" # pdata (getField @"pocfOfferedTokens" a' + getField @"pocfOfferedTokens" b') 101 | #$ pdcons @"pocfAskedTokens" # pdata (getField @"pocfAskedTokens" a' + getField @"pocfAskedTokens" b') 102 | #$ pdnil 103 | 104 | instance Monoid (Term s PPartialOrderContainedFee) where 105 | mempty = 106 | plet (pdata 0) $ \z -> 107 | pcon $ PPartialOrderContainedFee 108 | $ pdcons @"pocfLovelaces" # z 109 | #$ pdcons @"pocfOfferedTokens" # z 110 | #$ pdcons @"pocfAskedTokens" # z 111 | #$ pdnil 112 | 113 | type PartialOrderConfigRec 114 | = '[ "pocdSignatories" ':= PBuiltinList (PAsData PPubKeyHash) 115 | , "pocdReqSignatories" ':= PInteger 116 | , "pocdNftSymbol" ':= PCurrencySymbol 117 | , "pocdFeeAddr" ':= PAddress 118 | , "pocdMakerFeeFlat" ':= PInteger 119 | , "pocdMakerFeeRatio" ':= PRationalData 120 | , "pocdTakerFee" ':= PInteger 121 | , "pocdMinDeposit" ':= PInteger 122 | ] 123 | 124 | newtype PPartialOrderConfigDatum s 125 | = PPartialOrderConfigDatum (Term s (PDataRecord PartialOrderConfigRec)) 126 | deriving stock (Generic) 127 | deriving anyclass (PlutusType, PIsData, PEq, PDataFields) 128 | 129 | instance DerivePlutusType PPartialOrderConfigDatum where type DPTStrat _ = PlutusTypeData 130 | 131 | instance PTryFrom PData (PAsData PPartialOrderConfigDatum) 132 | 133 | type PartialOrderRec 134 | = '[ "podOwnerKey" ':= PPubKeyHash 135 | , "podOwnerAddr" ':= PAddress 136 | , "podOfferedAsset" ':= PAssetClass 137 | , "podOfferedOriginalAmount" ':= PInteger 138 | , "podOfferedAmount" ':= PInteger 139 | , "podAskedAsset" ':= PAssetClass 140 | , "podPrice" ':= PRationalData 141 | , "podNFT" ':= PTokenName 142 | , "podStart" ':= PMaybePPOSIXTimeData 143 | , "podEnd" ':= PMaybePPOSIXTimeData 144 | , "podPartialFills" ':= PInteger 145 | , "podMakerLovelaceFlatFee" ':= PInteger 146 | , "podTakerLovelaceFlatFee" ':= PInteger 147 | , "podContainedFee" ':= PPartialOrderContainedFee 148 | , "podContainedPayment" ':= PInteger 149 | ] 150 | 151 | newtype PPartialOrderDatum s 152 | = PPartialOrderDatum (Term s (PDataRecord PartialOrderRec)) 153 | deriving stock (Generic) 154 | deriving anyclass (PlutusType, PIsData, PEq, PDataFields) 155 | 156 | instance DerivePlutusType PPartialOrderDatum where type DPTStrat _ = PlutusTypeData 157 | 158 | instance PTryFrom PData (PAsData PPartialOrderDatum) 159 | 160 | -- | Plutarch's `PMaybeData` but specialised to `PPOSIXTime`. This was done to have `PTryFrom PData PMaybePPOSIXTimeData` instance as otherwise we were having instance of `PTryFrom PData (PMaybeData (PAsData PPOSIXTime))`, i.e., needed to add an extra `PAsData` wrapper around `PPOSIXTime`. 161 | data PMaybePPOSIXTimeData (s :: S) 162 | = PPDJust (Term s (PDataRecord '["_0" ':= PPOSIXTime])) 163 | | PPDNothing (Term s (PDataRecord '[])) 164 | deriving stock (Generic) 165 | deriving anyclass (PlutusType, PIsData, PEq, PShow) 166 | instance DerivePlutusType PMaybePPOSIXTimeData where type DPTStrat _ = PlutusTypeData 167 | instance PTryFrom PData PMaybePPOSIXTimeData 168 | instance PTryFrom PData (PAsData PMaybePPOSIXTimeData) 169 | 170 | data PPartialOrderAction (s :: S) 171 | = PPartialCancel (Term s (PDataRecord '[])) 172 | | PPartialFill (Term s (PDataRecord '["_0" ':= PInteger])) 173 | | PCompleteFill (Term s (PDataRecord '[])) 174 | deriving stock (Generic) 175 | deriving anyclass (PlutusType, PIsData, PEq) 176 | 177 | instance DerivePlutusType PPartialOrderAction where type DPTStrat _ = PlutusTypeData 178 | 179 | instance PTryFrom PData (PAsData PPartialOrderAction) 180 | -------------------------------------------------------------------------------- /geniusyield-onchain/src/GeniusYield/OnChain/DEX/PartialOrderConfig/Compiled.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module GeniusYield.OnChain.DEX.PartialOrderConfig.Compiled ( 4 | originalPartialOrderConfigValidator, 5 | optimizedPartialOrderConfigValidator, 6 | optimizedPartialOrderConfigValidatorWithTracing, 7 | ) where 8 | 9 | import Data.Default (def) 10 | import Data.Text (Text) 11 | import GeniusYield.OnChain.DEX.PartialOrderConfig 12 | import GeniusYield.OnChain.Plutarch.Api (PAssetClass) 13 | import GeniusYield.OnChain.Utils (desiredTracingMode) 14 | import GeniusYield.Plutonomy () 15 | import Plutarch 16 | import qualified Plutarch.Api.V2 as PV2 17 | import qualified Plutarch.Unsafe as PUNSAFE 18 | import qualified Plutonomy 19 | import PlutusLedgerApi.V1.Value (AssetClass) 20 | import Ply hiding ((#)) 21 | import Ply.Plutarch 22 | 23 | type POConfigScript = TypedScript 'ValidatorRole '[AssetClass] 24 | 25 | originalPartialOrderConfigValidator :: Config -> Either Text POConfigScript 26 | originalPartialOrderConfigValidator cnf = toTypedScript cnf mkPartialOrderConfigValidator' 27 | 28 | optimizedPartialOrderConfigValidator :: Either Text POConfigScript 29 | optimizedPartialOrderConfigValidator = Plutonomy.optimizeUPLC <$> originalPartialOrderConfigValidator def 30 | 31 | optimizedPartialOrderConfigValidatorWithTracing :: Either Text POConfigScript 32 | optimizedPartialOrderConfigValidatorWithTracing = Plutonomy.optimizeUPLC <$> originalPartialOrderConfigValidator def {tracingMode = desiredTracingMode} 33 | 34 | mkPartialOrderConfigValidator' :: 35 | ClosedTerm ( PAssetClass 36 | :--> PV2.PValidator 37 | ) 38 | mkPartialOrderConfigValidator' = plam $ \nftAC datm redm ctx -> 39 | popaque $ mkPartialOrderConfigValidator 40 | # nftAC 41 | # PUNSAFE.punsafeCoerce datm 42 | # PUNSAFE.punsafeCoerce redm 43 | # ctx 44 | -------------------------------------------------------------------------------- /geniusyield-onchain/src/GeniusYield/OnChain/DEX/PartialOrderNFT/Compiled.hs: -------------------------------------------------------------------------------- 1 | module GeniusYield.OnChain.DEX.PartialOrderNFT.Compiled ( 2 | originalPartialOrderNftPolicy, 3 | optimizedPartialOrderNftPolicy, 4 | optimizedPartialOrderNftPolicyWithTracing 5 | ) where 6 | 7 | 8 | import Data.Default (def) 9 | import Data.Text (Text) 10 | import Plutarch (Config (tracingMode)) 11 | import Plutarch.Api.V1 (PAddress) 12 | import Plutarch.Api.V1.Scripts (PScriptHash) 13 | import qualified Plutarch.Api.V2 as PV2 14 | import Plutarch.Prelude (ClosedTerm, plam, 15 | popaque, type (:-->), 16 | (#)) 17 | import qualified Plutarch.Unsafe as PUNSAFE 18 | import qualified Plutonomy 19 | import PlutusLedgerApi.V1 (Address, ScriptHash) 20 | import PlutusLedgerApi.V1.Value (AssetClass) 21 | import Ply (ScriptRole (MintingPolicyRole), 22 | TypedScript) 23 | import Ply.Plutarch (toTypedScript) 24 | 25 | import GeniusYield.OnChain.DEX.PartialOrderNFT (mkPartialOrderNFTPolicy) 26 | import GeniusYield.OnChain.Plutarch.Types (PAssetClass) 27 | import GeniusYield.OnChain.Utils (desiredTracingMode) 28 | import GeniusYield.Plutonomy () 29 | 30 | originalPartialOrderNftPolicy :: Config 31 | -> Either Text (TypedScript 'MintingPolicyRole '[ScriptHash, Address, AssetClass]) 32 | originalPartialOrderNftPolicy cnf = toTypedScript cnf mkPartialOrderNFTPolicy' 33 | 34 | optimizedPartialOrderNftPolicy :: Either Text (TypedScript 'MintingPolicyRole '[ScriptHash, Address, AssetClass]) 35 | optimizedPartialOrderNftPolicy = Plutonomy.optimizeUPLC <$> originalPartialOrderNftPolicy def 36 | 37 | optimizedPartialOrderNftPolicyWithTracing :: Either Text (TypedScript 'MintingPolicyRole '[ScriptHash, Address, AssetClass]) 38 | optimizedPartialOrderNftPolicyWithTracing = Plutonomy.optimizeUPLC <$> originalPartialOrderNftPolicy def {tracingMode = desiredTracingMode} 39 | 40 | mkPartialOrderNFTPolicy' :: ClosedTerm (PScriptHash :--> PAddress :--> PAssetClass :--> PV2.PMintingPolicy) 41 | mkPartialOrderNFTPolicy' = plam $ \sh refInputAddr refInputToken redm ctx -> 42 | popaque $ mkPartialOrderNFTPolicy 43 | # sh 44 | # refInputAddr 45 | # refInputToken 46 | # PUNSAFE.punsafeCoerce redm 47 | # ctx 48 | 49 | -------------------------------------------------------------------------------- /geniusyield-onchain/src/GeniusYield/OnChain/DEX/PartialOrderNFTV1_1/Compiled.hs: -------------------------------------------------------------------------------- 1 | module GeniusYield.OnChain.DEX.PartialOrderNFTV1_1.Compiled ( 2 | originalPartialOrderNftV1_1Policy, 3 | optimizedPartialOrderNftV1_1Policy, 4 | optimizedPartialOrderNftV1_1PolicyWithTracing, 5 | ) where 6 | 7 | import Data.Default (def) 8 | import Data.Text (Text) 9 | import Plutarch (Config (tracingMode)) 10 | import Plutarch.Api.V1 (PAddress) 11 | import Plutarch.Api.V1.Scripts (PScriptHash) 12 | import qualified Plutarch.Api.V2 as PV2 13 | import Plutarch.Prelude (ClosedTerm, plam, 14 | popaque, 15 | type (:-->), (#)) 16 | import qualified Plutarch.Unsafe as PUNSAFE 17 | import qualified Plutonomy 18 | import PlutusLedgerApi.V1 (Address, 19 | ScriptHash) 20 | import PlutusLedgerApi.V1.Value (AssetClass) 21 | import Ply (ScriptRole (MintingPolicyRole), 22 | TypedScript) 23 | import Ply.Plutarch (toTypedScript) 24 | 25 | import GeniusYield.OnChain.DEX.PartialOrderNFTV1_1 (mkPartialOrderNFTV1_1Policy) 26 | import GeniusYield.OnChain.Plutarch.Types (PAssetClass) 27 | import GeniusYield.OnChain.Utils (desiredTracingMode) 28 | import GeniusYield.Plutonomy () 29 | 30 | originalPartialOrderNftV1_1Policy :: 31 | Config -> 32 | Either Text (TypedScript 'MintingPolicyRole '[ScriptHash, Address, AssetClass]) 33 | originalPartialOrderNftV1_1Policy cnf = toTypedScript cnf mkPartialOrderNFTV1_1Policy' 34 | 35 | optimizedPartialOrderNftV1_1Policy :: Either Text (TypedScript 'MintingPolicyRole '[ScriptHash, Address, AssetClass]) 36 | optimizedPartialOrderNftV1_1Policy = Plutonomy.optimizeUPLC <$> originalPartialOrderNftV1_1Policy def 37 | 38 | optimizedPartialOrderNftV1_1PolicyWithTracing :: Either Text (TypedScript 'MintingPolicyRole '[ScriptHash, Address, AssetClass]) 39 | optimizedPartialOrderNftV1_1PolicyWithTracing = Plutonomy.optimizeUPLC <$> originalPartialOrderNftV1_1Policy def{tracingMode = desiredTracingMode} 40 | 41 | mkPartialOrderNFTV1_1Policy' :: ClosedTerm (PScriptHash :--> PAddress :--> PAssetClass :--> PV2.PMintingPolicy) 42 | mkPartialOrderNFTV1_1Policy' = plam $ \sh refInputAddr refInputToken redm ctx -> 43 | popaque $ 44 | mkPartialOrderNFTV1_1Policy 45 | # sh 46 | # refInputAddr 47 | # refInputToken 48 | # PUNSAFE.punsafeCoerce redm 49 | # ctx 50 | -------------------------------------------------------------------------------- /geniusyield-onchain/src/GeniusYield/OnChain/Plutarch/Api.hs: -------------------------------------------------------------------------------- 1 | module GeniusYield.OnChain.Plutarch.Api (module X) where 2 | 3 | import Plutarch.Extra.TermCont as X 4 | 5 | import GeniusYield.OnChain.Plutarch.Time as X 6 | import GeniusYield.OnChain.Plutarch.Tx as X 7 | import GeniusYield.OnChain.Plutarch.Types as X 8 | -------------------------------------------------------------------------------- /geniusyield-onchain/src/GeniusYield/OnChain/Plutarch/Crypto.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DerivingVia #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE StandaloneKindSignatures #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE TypeOperators #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | {-# OPTIONS_GHC -Wno-orphans #-} 15 | 16 | module GeniusYield.OnChain.Plutarch.Crypto ( PPubKey 17 | , PSignature 18 | , PSignedMessage 19 | , pverifySignedMessage 20 | ) where 21 | 22 | import Plutarch.Api.V1 23 | import qualified Plutarch.Api.V2 as PV2 24 | import Plutarch.Crypto 25 | import Plutarch.DataRepr 26 | import Plutarch.Prelude 27 | 28 | import GeniusYield.OnChain.Plutarch.Api (pguardC, pmatchC) 29 | import GeniusYield.OnChain.Plutarch.Utils (pparseDatum) 30 | 31 | type PSignature :: PType 32 | type PSignature = PByteString 33 | 34 | type PPubKey :: PType 35 | type PPubKey = PByteString 36 | 37 | newtype PSignedMessage (a :: PType) (s :: S) 38 | = PSignedMessage ( Term 39 | s 40 | ( PDataRecord 41 | '[ "signature" ':= PSignature 42 | , "messageHash" ':= PDatumHash 43 | ] 44 | ) 45 | ) 46 | deriving stock (Generic) 47 | deriving anyclass (PlutusType, PIsData, PEq, PDataFields) 48 | 49 | instance DerivePlutusType (PSignedMessage a) where type DPTStrat _ = PlutusTypeData 50 | 51 | pverifySignedMessage :: forall (s :: S) (a :: PType). PTryFrom PData (PAsData a) => 52 | Term s ( PPubKey 53 | :--> PSignedMessage a 54 | :--> PV2.PTxInfo 55 | :--> PAsData a 56 | ) 57 | pverifySignedMessage = plam $ \pk signedMsg info 58 | -> unTermCont $ do 59 | a@(PDatumHash dh) <- pmatchC (pfield @"messageHash" # signedMsg) 60 | let sig = pfield @"signature" # signedMsg 61 | 62 | pguardC "invalid signature" (pverifyEd25519Signature # pk # dh # sig) 63 | 64 | mtype <- pmatchC $ pparseDatum # pcon a #$ pfield @"datums" # info 65 | 66 | case mtype of 67 | PNothing -> return $ ptraceError "datum not found" 68 | PJust x -> return x 69 | -------------------------------------------------------------------------------- /geniusyield-onchain/src/GeniusYield/OnChain/Plutarch/Run.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE PartialTypeSignatures #-} 4 | {-# LANGUAGE QuantifiedConstraints #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | 7 | module GeniusYield.OnChain.Plutarch.Run 8 | ( applyArguments 9 | , evalT 10 | , evalSerialize 11 | , evalWithArgsT 12 | , evalWithArgsT' 13 | ) where 14 | 15 | import Control.Lens.Combinators (over) 16 | import Data.Bifunctor (first) 17 | import Data.ByteString.Short (ShortByteString) 18 | import Data.Default (def) 19 | import Data.Text (Text, pack) 20 | import Plutarch (ClosedTerm, compile) 21 | import Plutarch.Evaluate (evalScript) 22 | import Plutarch.Script (Script (Script, unScript), serialiseScript) 23 | import PlutusCore.MkPlc (mkConstant, mkIterApp) 24 | import PlutusLedgerApi.V1 (Data, ExBudget) 25 | import UntypedPlutusCore (DeBruijn, DefaultFun, DefaultUni, Program, progTerm) 26 | 27 | applyArguments :: Script -> [Data] -> Script 28 | applyArguments (Script p) args = 29 | let termArgs = mkConstant () <$> args 30 | applied t = mkIterApp () t termArgs 31 | in Script $ over progTerm applied p 32 | 33 | evalSerialize :: ClosedTerm a -> Either Text ShortByteString 34 | evalSerialize x = serialiseScript . (\(a, _, _) -> a) <$> evalT x 35 | 36 | evalT :: ClosedTerm a -> Either Text (Script, ExBudget, [Text]) 37 | evalT x = evalWithArgsT x [] 38 | 39 | evalWithArgsT :: ClosedTerm a -> [Data] -> Either Text (Script, ExBudget, [Text]) 40 | evalWithArgsT x args = do 41 | cmp <- compile def x 42 | let (escr, budg, trc) = evalScript $ applyArguments cmp args 43 | scr <- first (pack . show) escr 44 | pure (scr, budg, trc) 45 | 46 | evalWithArgsT' :: ClosedTerm a -> [Data] -> Either Text (Program DeBruijn DefaultUni DefaultFun (), ExBudget, [Text]) 47 | evalWithArgsT' x args = 48 | (\(res, budg, trcs) -> (unScript res, budg, trcs)) 49 | <$> evalWithArgsT x args 50 | -------------------------------------------------------------------------------- /geniusyield-onchain/src/GeniusYield/OnChain/Plutarch/Time.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | 7 | module GeniusYield.OnChain.Plutarch.Time ( pcontains 8 | , plowerbound 9 | , pupperBound 10 | , pinterval 11 | , pFrom 12 | , pTo 13 | ) where 14 | 15 | import Plutarch.Api.V1 16 | import Plutarch.Extra.TermCont (pletFieldsC) 17 | import Plutarch.Prelude 18 | 19 | {- | 'pcontains' is the plutarch level function that is similar to 'contains' defined in "Ledger". 20 | The function checks whether the second interval 'PPOSIXTimeRange' is completely contained 21 | withing first 'PPOSIXTimeRange'. 22 | -} 23 | pcontains :: 24 | Term s (PPOSIXTimeRange 25 | :--> PPOSIXTimeRange 26 | :--> PBool 27 | ) 28 | pcontains = phoistAcyclic $ plam $ \interval1 interval2 29 | -> unTermCont $ do 30 | v1 <- pletFieldsC @'["from", "to"] interval1 31 | v2 <- pletFieldsC @'["from", "to"] interval2 32 | 33 | let lb1 = pfromData $ getField @"from" v1 34 | lb2 = pfromData $ getField @"from" v2 35 | 36 | ub1 = pfromData $ getField @"to" v1 37 | ub2 = pfromData $ getField @"to" v2 38 | 39 | return ( lb1 #<= lb2 40 | #&& ub2 #<= ub1 41 | ) 42 | 43 | 44 | -- | 'plowerbound' is plutarch level function of 'lowerBound'. 45 | plowerbound :: Term s (PPOSIXTime :--> PLowerBound PPOSIXTime) 46 | plowerbound = phoistAcyclic $ plam $ \a 47 | -> let 48 | lbValue = pcon $ PFinite (pdcons @"_0" # pdata a # pdnil) 49 | lb = PLowerBound (pdcons @"_0" # pdata lbValue #$ 50 | pdcons @"_1" # pdata (pconstant True) # pdnil 51 | ) 52 | in 53 | pcon lb 54 | 55 | 56 | -- | 'pupperBound' is plutarch level function of 'upperBound'. 57 | pupperBound :: Term s (PPOSIXTime :--> PUpperBound PPOSIXTime) 58 | pupperBound = phoistAcyclic $ plam $ \a 59 | -> let 60 | ubValue = pcon $ PFinite (pdcons @"_0" # pdata a # pdnil) 61 | ub = PUpperBound (pdcons @"_0" # pdata ubValue #$ 62 | pdcons @"_1" # pdata (pconstant True) # pdnil 63 | ) 64 | in 65 | pcon ub 66 | 67 | -- | 'pFrom' is the plutarch level function of 'from'. 68 | pFrom :: 69 | Term s (PPOSIXTime 70 | :--> PInterval PPOSIXTime 71 | ) 72 | pFrom = phoistAcyclic $ plam $ \a 73 | -> let 74 | lb = plowerbound # a 75 | ubValue = pcon $ PPosInf pdnil 76 | ub = pcon $ PUpperBound (pdcons @"_0" # pdata ubValue #$ 77 | pdcons @"_1" # pdata (pconstant True) # pdnil 78 | ) 79 | in 80 | pcon $ PInterval (pdcons @"from" # pdata lb #$ 81 | pdcons @"to" # pdata ub # pdnil 82 | ) 83 | 84 | -- | 'pTo' is the plutarch level function of 'to'. 85 | pTo :: 86 | Term s (PPOSIXTime 87 | :--> PInterval PPOSIXTime 88 | ) 89 | pTo = phoistAcyclic $ plam $ \a 90 | -> let 91 | lbValue = pcon $ PNegInf pdnil 92 | lb = pcon $ PLowerBound (pdcons @"_0" # pdata lbValue #$ 93 | pdcons @"_1" # pdata (pconstant True) # pdnil 94 | ) 95 | ub = pupperBound # a 96 | in 97 | pcon $ PInterval (pdcons @"from" # pdata lb #$ 98 | pdcons @"to" # pdata ub # pdnil 99 | ) 100 | 101 | -- | 'pinterval' is plutarch level function of 'interval'. 102 | pinterval :: 103 | Term s (PPOSIXTime 104 | :--> PPOSIXTime 105 | :--> PInterval PPOSIXTime 106 | ) 107 | pinterval = phoistAcyclic $ plam $ \lowerB upperB 108 | -> let 109 | lb = plowerbound # lowerB 110 | ub = pupperBound # upperB 111 | in 112 | pcon $ PInterval (pdcons @"from" # pdata lb #$ 113 | pdcons @"to" # pdata ub # pdnil 114 | ) 115 | -------------------------------------------------------------------------------- /geniusyield-onchain/src/GeniusYield/OnChain/Plutarch/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module GeniusYield.OnChain.Plutarch.Types where 4 | 5 | import Plutarch.Api.V1 6 | import Plutarch.DataRepr 7 | import Plutarch.Extra.RationalData (PRationalData) 8 | import Plutarch.Prelude 9 | import PlutusLedgerApi.V1.Value (AssetClass) 10 | import qualified PlutusTx.Ratio as PlutusTx 11 | import Ply.Plutarch.Class (PlyArgOf) 12 | 13 | {- | 'PAssetClass' is the plutarch level type for 'AssetClass' defined in "Ledger.Value". 14 | -} 15 | newtype PAssetClass (s :: S) 16 | = PAssetClass 17 | ( Term 18 | s 19 | ( PDataRecord 20 | '[ "currencySymbol" ':= PCurrencySymbol 21 | , "tokenName" ':= PTokenName 22 | ] 23 | ) 24 | ) 25 | deriving stock (Generic) 26 | deriving anyclass (PlutusType, PIsData, PEq, PDataFields, PTryFrom PData) 27 | 28 | instance DerivePlutusType PAssetClass where type DPTStrat _ = PlutusTypeData 29 | 30 | instance PTryFrom PData (PAsData PAssetClass) 31 | 32 | type instance PlyArgOf PAssetClass = AssetClass 33 | 34 | newtype Flip f a b = Flip (f b a) 35 | deriving stock (Generic) 36 | 37 | type instance PlyArgOf PRationalData = PlutusTx.Rational 38 | -------------------------------------------------------------------------------- /geniusyield-onchain/src/GeniusYield/OnChain/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# OPTIONS -fno-strictness -fno-spec-constr -fno-specialise #-} 4 | 5 | module GeniusYield.OnChain.Utils 6 | ( paidValue 7 | , paidValue' 8 | , integerToBuiltinByteString, builtinByteStringToHex 9 | , ceiling 10 | , mintedTokens 11 | , notSignedBy 12 | , desiredTracingMode 13 | ) where 14 | 15 | import Plutarch (TracingMode (DoTracing)) 16 | import PlutusLedgerApi.V1 17 | import qualified PlutusTx.AssocMap as Map 18 | import PlutusTx.Prelude 19 | import PlutusTx.Ratio 20 | 21 | {-# INLINABLE paidValue #-} 22 | paidValue :: ScriptContext -> Address -> Value 23 | paidValue ctx' = case scriptContextPurpose ctx' of 24 | Spending x -> paidValue' x $ scriptContextTxInfo ctx' 25 | _ -> error () 26 | 27 | {-# INLINABLE paidValue' #-} 28 | paidValue' :: TxOutRef -> TxInfo -> Address -> Value 29 | paidValue' ownUTxO' info' addr = go $ txInfoOutputs info' 30 | where 31 | go :: [TxOut] -> Value 32 | go xs = 33 | let 34 | o = head xs 35 | in 36 | if p o 37 | then txOutValue o 38 | else go $ tail xs 39 | 40 | expectedHash :: Maybe DatumHash 41 | expectedHash = go' $ txInfoData info' 42 | where 43 | go' :: [(DatumHash, Datum)] -> Maybe DatumHash 44 | go' xs = 45 | let 46 | (dh, d) = head xs 47 | in 48 | if d == expectedDatum 49 | then Just dh 50 | else go' $ tail xs 51 | 52 | expectedDatum :: Datum 53 | expectedDatum = Datum $ toBuiltinData ownUTxO' 54 | 55 | p :: TxOut -> Bool 56 | p o = (txOutAddress o == addr) && (txOutDatumHash o == expectedHash) 57 | 58 | {-# INLINABLE integerToBuiltinByteString #-} 59 | integerToBuiltinByteString :: Integer -> BuiltinByteString 60 | integerToBuiltinByteString n 61 | | n < 0 = traceError "only non-negative Integers can be converted" 62 | | n == 0 = 48 `consByteString` emptyByteString 63 | | otherwise = go n emptyByteString 64 | where 65 | go :: Integer -> BuiltinByteString -> BuiltinByteString 66 | go m acc 67 | | m == 0 = acc 68 | | otherwise = 69 | let 70 | m' = m `divide` 10 71 | r = m `modulo` 10 72 | in 73 | go m' $ consByteString (r + 48) acc 74 | 75 | {-# INLINABLE builtinByteStringToHex #-} 76 | builtinByteStringToHex :: BuiltinByteString -> BuiltinByteString 77 | builtinByteStringToHex s = go (lengthOfByteString s - 1) emptyByteString 78 | where 79 | go :: Integer -> BuiltinByteString -> BuiltinByteString 80 | go i acc 81 | | i < 0 = acc 82 | | otherwise = go (i - 1) $ appendByteString (byteToBuiltinByteString $ indexByteString s i) acc 83 | 84 | {-# INLINABLE byteToBuiltinByteString #-} 85 | byteToBuiltinByteString :: Integer -> BuiltinByteString 86 | byteToBuiltinByteString n = consByteString (digitToByte h) $ consByteString (digitToByte l) emptyByteString 87 | where 88 | h = divide n 16 89 | l = modulo n 16 90 | 91 | digitToByte :: Integer -> Integer 92 | digitToByte x 93 | | x <= 9 = x + 48 94 | | otherwise = x + 87 95 | 96 | {-# INLINABLE ceiling #-} 97 | ceiling :: Rational -> Integer 98 | ceiling x 99 | | x < zero = truncate x 100 | | x == y = truncate x 101 | | otherwise = 1 + truncate x 102 | where 103 | y = fromInteger $ truncate x 104 | 105 | {-# INLINABLE mintedTokens #-} 106 | mintedTokens :: CurrencySymbol -> TokenName -> TxInfo -> Integer 107 | mintedTokens cs tn info = 108 | let 109 | Just m = Map.lookup cs $ getValue $ txInfoMint info 110 | in 111 | fromMaybe 0 $ Map.lookup tn m 112 | 113 | notSignedBy :: TxInfo -> PubKeyHash -> Bool 114 | notSignedBy info' pkh' = go $ txInfoSignatories info' 115 | where 116 | go :: [PubKeyHash] -> Bool 117 | go xs = null xs || (head xs /= pkh' && go (tail xs)) 118 | 119 | desiredTracingMode :: TracingMode 120 | desiredTracingMode = DoTracing 121 | -------------------------------------------------------------------------------- /geniusyield-onchain/src/GeniusYield/Plutonomy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE UnboxedTuples #-} 3 | {-# OPTIONS_GHC -Wno-orphans #-} 4 | 5 | -- | Extras to be added to @plutonomy@. 6 | module GeniusYield.Plutonomy ( 7 | plutonomyMintingPolicyFromScript, 8 | plutonomyValidatorFromScript 9 | ) where 10 | 11 | import qualified Plutonomy 12 | import qualified PlutusTx.Code 13 | import qualified UntypedPlutusCore as UPLC 14 | import Ply 15 | import qualified Ply.Core.Unsafe as PlyUnsafe 16 | 17 | instance Plutonomy.HasUPLC (TypedScript rl params) where 18 | uplc f ts = PlyUnsafe.unsafeTypedScript ver <$> Plutonomy.uplc f scrpt 19 | where 20 | (# ver, scrpt #) = PlyUnsafe.unsafeUnTypedScript ts 21 | 22 | renameUPLC :: (name -> name') -> UPLC.Term name uni fun ann -> UPLC.Term name' uni fun ann 23 | renameUPLC rnm = go where 24 | go (UPLC.Var ann n ) = UPLC.Var ann (rnm n) 25 | go (UPLC.LamAbs ann n t ) = UPLC.LamAbs ann (rnm n) (go t) 26 | go (UPLC.Apply ann t1 t2 ) = UPLC.Apply ann (go t1) (go t2) 27 | go (UPLC.Delay ann t ) = UPLC.Delay ann (go t) 28 | go (UPLC.Force ann t ) = UPLC.Force ann (go t) 29 | go (UPLC.Constant ann con) = UPLC.Constant ann con 30 | go (UPLC.Builtin ann bn ) = UPLC.Builtin ann bn 31 | go (UPLC.Error ann ) = UPLC.Error ann 32 | 33 | renameProgram :: (name -> name') -> UPLC.Program name uni fun ann -> UPLC.Program name' uni fun ann 34 | renameProgram f (UPLC.Program ann ver t) = UPLC.Program ann ver (renameUPLC f t) 35 | 36 | namedFromDeBruijn :: UPLC.DeBruijn -> UPLC.NamedDeBruijn 37 | namedFromDeBruijn (UPLC.DeBruijn i) = UPLC.NamedDeBruijn "x" i 38 | 39 | plutonomyMintingPolicyFromScript :: TypedScript 'MintingPolicyRole '[] -> Plutonomy.MintingPolicy 40 | plutonomyMintingPolicyFromScript (TypedScript _ s) = 41 | Plutonomy.mkMintingPolicyScript $ 42 | PlutusTx.Code.DeserializedCode (renameProgram namedFromDeBruijn s) Nothing mempty 43 | 44 | plutonomyValidatorFromScript :: TypedScript 'ValidatorRole '[] -> Plutonomy.Validator 45 | plutonomyValidatorFromScript (TypedScript _ s) = 46 | Plutonomy.mkValidatorScript $ 47 | PlutusTx.Code.DeserializedCode (renameProgram namedFromDeBruijn s) Nothing mempty 48 | -------------------------------------------------------------------------------- /geniusyield-onchain/tests/geniusyield-onchain-tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE NumericUnderscores #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Main 6 | ( main 7 | ) where 8 | 9 | import Control.Exception (throwIO) 10 | import Data.Default (def) 11 | import Data.Text (Text) 12 | import qualified Data.Text as Txt 13 | import qualified Plutonomy as P 14 | import Plutonomy.Test (TestOptions (TestOptions, toAggSize, toFixturesDir, toName, toOptSize, toTerm, toUnoptSize), 15 | plutonomyTests) 16 | import PlutusLedgerApi.V1.Address (Address (..)) 17 | import PlutusLedgerApi.V1.Credential (Credential (..)) 18 | import PlutusLedgerApi.V1.Value (assetClass) 19 | import Ply ((#)) 20 | import Test.Tasty (defaultMain, testGroup) 21 | 22 | import GeniusYield.OnChain.DEX.NFT.Compiled (originalNftPolicy) 23 | import GeniusYield.OnChain.DEX.PartialOrder.Compiled (originalPartialOrderValidator) 24 | import GeniusYield.OnChain.DEX.PartialOrderNFT.Compiled (originalPartialOrderNftPolicy) 25 | 26 | 27 | 28 | import GeniusYield.OnChain.DEX.PartialOrderConfig.Compiled (originalPartialOrderConfigValidator) 29 | import GeniusYield.OnChain.DEX.PartialOrderNFTV1_1.Compiled (originalPartialOrderNftV1_1Policy) 30 | import GeniusYield.Plutonomy (plutonomyMintingPolicyFromScript, 31 | plutonomyValidatorFromScript) 32 | 33 | getOrthrowText :: Either Text a -> IO a 34 | getOrthrowText = either (throwIO . userError . Txt.unpack) pure 35 | 36 | main :: IO () 37 | main = do 38 | partialOrderVal <- getOrthrowText $ originalPartialOrderValidator def 39 | partialOrderNftPolicy <- getOrthrowText $ originalPartialOrderNftPolicy def 40 | partialOrderNftPolicyV1_1 <- getOrthrowText $ originalPartialOrderNftV1_1Policy def 41 | partialOrderConfigVal <- getOrthrowText $ originalPartialOrderConfigValidator def 42 | nftPolicy <- getOrthrowText originalNftPolicy 43 | let plutonomyRawFromValidator = P.validatorToRaw . plutonomyValidatorFromScript 44 | plutonomyRawFromMintingPolicy = P.mintingPolicyToRaw . plutonomyMintingPolicyFromScript 45 | defaultMain $ testGroup "geniusyield" 46 | [ testGroup "DEX" 47 | [ plutonomyTests TestOptions 48 | { toName = "partialorder" 49 | , toTerm = plutonomyRawFromValidator $ partialOrderVal 50 | # anAddress 51 | # ac 52 | , toUnoptSize = (6_037, 5_629) 53 | , toOptSize = (5_369, 4_936) 54 | , toAggSize = (5_369, 4_936) 55 | , toFixturesDir = "fixtures" 56 | } 57 | , plutonomyTests TestOptions 58 | { toName = "partialordernftpolicy" 59 | , toTerm = plutonomyRawFromMintingPolicy $ partialOrderNftPolicy 60 | # aScriptHash 61 | # anAddress 62 | # ac 63 | , toUnoptSize = (6_040, 5_652) 64 | , toOptSize = (5_082, 4_546) 65 | , toAggSize = (5_082, 4_546) 66 | , toFixturesDir = "fixtures" 67 | } 68 | , plutonomyTests TestOptions 69 | { toName = "partialordernftpolicyV1_1" 70 | , toTerm = plutonomyRawFromMintingPolicy $ partialOrderNftPolicyV1_1 71 | # aScriptHash 72 | # anAddress 73 | # ac 74 | , toUnoptSize = (6_040, 5_652) 75 | , toOptSize = (5_082, 4_546) 76 | , toAggSize = (5_082, 4_546) 77 | , toFixturesDir = "fixtures" 78 | } 79 | , plutonomyTests TestOptions 80 | { toName = "partialorderconfig" 81 | , toTerm = plutonomyRawFromValidator $ partialOrderConfigVal # ac 82 | , toUnoptSize = (2_978, 2_630) 83 | , toOptSize = (2_559, 2_250) 84 | , toAggSize = (2_559, 2_250) 85 | , toFixturesDir = "fixtures" 86 | } 87 | , plutonomyTests TestOptions 88 | { toName = "nftpolicy" 89 | , toTerm = plutonomyRawFromMintingPolicy nftPolicy 90 | , toUnoptSize = (507,440) 91 | , toOptSize = (445,388) 92 | , toAggSize = (445,388) 93 | , toFixturesDir = "fixtures" 94 | } 95 | ] 96 | ] 97 | where 98 | aScriptHash = "e2f9d92651c75a28717bf5622e6164e25133d856e9c02ea21a234dfc" 99 | anAddress = Address (PubKeyCredential "a881d6369fa731377d82d806d8deb2067878129a5e2df96c25e5a08e") Nothing 100 | cs = "be18c29c7f0ffca5c3e6cd56f97df0f82a31e317e99bfa031b3b0fe3" 101 | tn = "47454e53" 102 | ac = assetClass cs tn 103 | -------------------------------------------------------------------------------- /geniusyield-orderbot-lib/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for geniusyield-orderbot-lib 2 | 3 | ## 0.1.0 -- 2023-04-02 4 | 5 | * First version. 6 | -------------------------------------------------------------------------------- /geniusyield-orderbot-lib/README.md: -------------------------------------------------------------------------------- 1 | # GeniusYield Orderbot Framework 2 | 3 | GeniusYield orderbot library, providing common utilities which different orderbots such as market-maker, smart-order-router, etc. can utilize. -------------------------------------------------------------------------------- /geniusyield-orderbot-lib/geniusyield-orderbot-lib.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.6 2 | name: geniusyield-orderbot-lib 3 | version: 0.1.0 4 | synopsis: 5 | GeniusYield orderbot library, providing common utilities which different orderbots such as market-maker, smart-order-router, etc. can use. 6 | 7 | description: 8 | GeniusYield orderbot library, providing common utilities which different orderbots such as market-maker, smart-order-router, etc. can use. Learn more about GeniusYield by visiting https://www.geniusyield.co/. 9 | 10 | license: Apache-2.0 11 | license-file: LICENSE 12 | bug-reports: http://github.com/geniusyield/dex-contracts-api/issues 13 | author: GeniusYield 14 | maintainer: support@geniusyield.co 15 | copyright: 2024 GYELD GMBH 16 | build-type: Simple 17 | category: Blockchain, Cardano 18 | extra-doc-files: 19 | CHANGELOG.md 20 | README.md 21 | 22 | tested-with: GHC ==9.6.5 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/geniusyield/dex-contracts-api.git 27 | 28 | common common 29 | default-language: GHC2021 30 | default-extensions: 31 | NoImplicitPrelude 32 | DataKinds 33 | DeriveAnyClass 34 | DerivingStrategies 35 | DerivingVia 36 | FunctionalDependencies 37 | GADTs 38 | LambdaCase 39 | MultiWayIf 40 | OverloadedStrings 41 | RecordWildCards 42 | RoleAnnotations 43 | TemplateHaskell 44 | TypeFamilies 45 | TypeFamilyDependencies 46 | UndecidableInstances 47 | UnicodeSyntax 48 | ViewPatterns 49 | 50 | ghc-options: -Wall -Wincomplete-uni-patterns -Wunused-packages 51 | 52 | -- Speed-ups GHCi considerably. 53 | ghc-options: -fno-show-valid-hole-fits 54 | 55 | library 56 | import: common 57 | hs-source-dirs: src 58 | exposed-modules: 59 | GeniusYield.OrderBot.Adapter.Maestro 60 | GeniusYield.OrderBot.Domain.Assets 61 | GeniusYield.OrderBot.Domain.Markets 62 | 63 | build-depends: 64 | , aeson 65 | , base ^>=4.18.2.0 66 | , deriving-aeson 67 | , http-api-data 68 | , lens 69 | , rio 70 | , swagger2 71 | 72 | -- Dependencies whose version is fixed by @cabal.project@ file. 73 | build-depends: 74 | , atlas-cardano 75 | , maestro-sdk -------------------------------------------------------------------------------- /geniusyield-orderbot-lib/src/GeniusYield/OrderBot/Adapter/Maestro.hs: -------------------------------------------------------------------------------- 1 | module GeniusYield.OrderBot.Adapter.Maestro ( 2 | MaestroProvider (..), 3 | handleMaestroError, 4 | ) where 5 | 6 | import GeniusYield.OrderBot.Domain.Assets (adaAssetDetails) 7 | import GeniusYield.OrderBot.Domain.Assets qualified as Domain 8 | import GeniusYield.OrderBot.Domain.Markets qualified as Domain 9 | import GeniusYield.Types (GYAssetClass (..), mintingPolicyIdToText, parseAssetClassWithSep, tokenNameToHex) 10 | import Maestro.Client.V1 11 | import Maestro.Types.V1 12 | import RIO 13 | import RIO.Text (pack) 14 | 15 | -- Exception utilities 16 | 17 | data MaestroProviderException 18 | = MpeDeserializationException !Text 19 | | MpeRequestException !Text !MaestroError 20 | deriving stock (Show) 21 | deriving anyclass (Exception) 22 | 23 | -- | Utility function to handle Maestro errors. 24 | handleMaestroError ∷ Text → Either MaestroError a → IO a 25 | handleMaestroError locationInfo = either (throwIO . MpeRequestException locationInfo) pure 26 | 27 | newtype MaestroProvider = MaestroProvider (MaestroEnv 'V1) 28 | 29 | instance Domain.HasAssets MaestroProvider where 30 | getAssetDetails (MaestroProvider menv) ac = case ac of 31 | GYLovelace → pure adaAssetDetails 32 | GYToken polId tkName → do 33 | AssetInfo {assetInfoTokenRegistryMetadata} ← try (getTimestampedData <$> assetInfo menv (NonAdaNativeToken (PolicyId . mintingPolicyIdToText $ polId) (TokenName . tokenNameToHex $ tkName))) >>= handleMaestroError (locationInfoPrefix <> "fetching particular token details") 34 | case assetInfoTokenRegistryMetadata of 35 | Nothing → pure $ Domain.AssetDetails ac Nothing Nothing 36 | Just TokenRegistryMetadata {tokenRegistryMetadataTicker, tokenRegistryMetadataDecimals} → pure $ Domain.AssetDetails ac (Domain.AssetTicker <$> tokenRegistryMetadataTicker) (Domain.AssetDecimals <$> tokenRegistryMetadataDecimals) 37 | where 38 | locationInfoPrefix = "getAssetDetails: " 39 | 40 | instance Domain.HasMarkets MaestroProvider where 41 | getMarkets (MaestroProvider menv) = do 42 | DexPairResponse {dexPairResponsePairs} ← try (pairsFromDex menv GeniusYield) >>= handleMaestroError (locationInfoPrefix <> "fetching market pairs") 43 | traverse fromDexPairInfo dexPairResponsePairs 44 | where 45 | locationInfoPrefix = "getMarkets: " 46 | 47 | fromDexPairInfo DexPairInfo {..} = do 48 | a ← getAssetClass dexPairInfoCoinAPolicy dexPairInfoCoinAAssetName 49 | b ← getAssetClass dexPairInfoCoinBPolicy dexPairInfoCoinBAssetName 50 | pure $ Domain.mkOrderAssetPair a b 51 | 52 | getAssetClass (PolicyId polId) (TokenName tkName) = 53 | if polId == mempty 54 | then pure GYLovelace 55 | else case parseAssetClassWithSep '.' (polId <> "." <> tkName) of 56 | Left e → throwIO $ MpeDeserializationException (pack e) 57 | Right ac → pure ac 58 | -------------------------------------------------------------------------------- /geniusyield-orderbot-lib/src/GeniusYield/OrderBot/Domain/Assets.hs: -------------------------------------------------------------------------------- 1 | module GeniusYield.OrderBot.Domain.Assets ( 2 | AssetTicker (..), 3 | AssetDecimals (..), 4 | AssetDetails (..), 5 | adaAssetDetails, 6 | HasAssets (..), 7 | ) where 8 | 9 | import Data.Aeson (ToJSON (..)) 10 | import Data.Swagger 11 | import Data.Swagger qualified as Swagger 12 | import Deriving.Aeson 13 | import GHC.TypeLits (Symbol) 14 | import GeniusYield.Swagger.Utils (addSwaggerDescription, addSwaggerExample, dropSymbolAndCamelToSnake) 15 | import GeniusYield.Types (GYAssetClass (..)) 16 | import RIO 17 | import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) 18 | 19 | {- $setup 20 | 21 | >>> :set -XOverloadedStrings -XTypeApplications 22 | >>> import qualified Data.Aeson as Aeson 23 | >>> import Data.Proxy 24 | >>> import qualified Data.Swagger as Swagger 25 | -} 26 | 27 | newtype AssetTicker = AssetTicker Text 28 | deriving stock (Show, Eq, Generic) 29 | deriving newtype (FromJSON, ToJSON, FromHttpApiData, ToHttpApiData) 30 | 31 | instance Swagger.ToSchema AssetTicker where 32 | declareNamedSchema = 33 | Swagger.genericDeclareNamedSchema Swagger.defaultSchemaOptions 34 | & addSwaggerDescription "Ticker of an asset." 35 | & addSwaggerExample "ADA" 36 | 37 | newtype AssetDecimals = AssetDecimals Word64 38 | deriving stock (Show, Eq, Generic) 39 | deriving newtype (Num, FromJSON, ToJSON, FromHttpApiData, ToHttpApiData) 40 | 41 | instance Swagger.ToSchema AssetDecimals where 42 | declareNamedSchema = 43 | Swagger.genericDeclareNamedSchema Swagger.defaultSchemaOptions 44 | & addSwaggerDescription "Decimals of an asset." 45 | & addSwaggerExample (toJSON (6 ∷ AssetDecimals)) 46 | 47 | type AssetDetailsPrefix ∷ Symbol 48 | type AssetDetailsPrefix = "ad" 49 | 50 | data AssetDetails = AssetDetails 51 | { adAsset ∷ !GYAssetClass, 52 | adAssetTicker ∷ !(Maybe AssetTicker), 53 | adAssetDecimals ∷ !(Maybe AssetDecimals) 54 | } 55 | deriving stock (Show, Eq, Generic) 56 | deriving 57 | (FromJSON, ToJSON) 58 | via CustomJSON '[FieldLabelModifier '[StripPrefix AssetDetailsPrefix, CamelToSnake]] AssetDetails 59 | 60 | -- >>> Aeson.encode (Swagger.toSchema (Proxy :: Proxy AssetDetails)) 61 | -- "{\"description\":\"Asset details.\",\"required\":[\"asset\"],\"properties\":{\"asset\":{\"$ref\":\"#/definitions/GYAssetClass\"},\"asset_ticker\":{\"$ref\":\"#/definitions/AssetTicker\"},\"asset_decimals\":{\"$ref\":\"#/definitions/AssetDecimals\"}},\"type\":\"object\"}" 62 | instance Swagger.ToSchema AssetDetails where 63 | declareNamedSchema = 64 | Swagger.genericDeclareNamedSchema Swagger.defaultSchemaOptions {Swagger.fieldLabelModifier = dropSymbolAndCamelToSnake @AssetDetailsPrefix} 65 | & addSwaggerDescription "Asset details." 66 | 67 | adaAssetDetails ∷ AssetDetails 68 | adaAssetDetails = 69 | AssetDetails 70 | { adAssetTicker = Just $ AssetTicker "ADA", 71 | adAssetDecimals = Just 6, 72 | adAsset = GYLovelace 73 | } 74 | 75 | class HasAssets a where 76 | getAssetDetails ∷ a → GYAssetClass → IO AssetDetails 77 | -------------------------------------------------------------------------------- /geniusyield-orderbot-lib/src/GeniusYield/OrderBot/Domain/Markets.hs: -------------------------------------------------------------------------------- 1 | module GeniusYield.OrderBot.Domain.Markets ( 2 | HasMarkets (..), 3 | OrderAssetPair (currencyAsset, commodityAsset), 4 | mkOrderAssetPair, 5 | equivalentAssetPair, 6 | mkEquivalentAssetPair, 7 | ) where 8 | 9 | import Control.Lens ((?~)) 10 | import Data.Aeson (FromJSON (..), ToJSON (..)) 11 | import Data.Aeson qualified as Aeson 12 | import Data.Swagger qualified as Swagger 13 | import Data.Swagger.Internal.Schema qualified as Swagger 14 | import GeniusYield.Types (GYAssetClass) 15 | import RIO 16 | import RIO.Text qualified as Text 17 | import RIO.Text.Partial qualified as Text 18 | import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) 19 | 20 | {- | The asset pair in a DEX Order. 21 | 22 | All 'OrderAssetPair's constructed out of equivalent raw asset pairs, must compare equal. See: 'equivalentAssetPair'. 23 | 24 | For each unique asset pair (see: 'mkAssetPair'), one asset is chosen as the "commodity" (being sold), and the other 25 | is chosen as the "currency" - this makes it simpler to perform order matching. 26 | -} 27 | data OrderAssetPair = OAssetPair 28 | { currencyAsset ∷ !GYAssetClass, 29 | commodityAsset ∷ !GYAssetClass 30 | } 31 | deriving stock (Eq, Ord, Show) 32 | 33 | instance ToJSON OrderAssetPair where 34 | toJSON oap = 35 | Aeson.String $ toUrlPiece oap 36 | 37 | instance FromJSON OrderAssetPair where 38 | parseJSON = Aeson.withText "OrderAssetPair" $ \t → 39 | case parseUrlPiece t of 40 | Left e → fail $ Text.unpack e 41 | Right oap → pure oap 42 | 43 | -- >>> toUrlPiece $ OAssetPair {currencyAsset = GYLovelace, commodityAsset = GYLovelace} 44 | -- "_" 45 | -- >>> toUrlPiece $ OAssetPair {currencyAsset = GYToken "f43a62fdc3965df486de8a0d32fe800963589c41b38946602a0dc535" "AGIX", commodityAsset = GYToken "f43a62fdc3965df486de8a0d32fe800963589c41b38946602a0dc535" "AGIX"} 46 | -- "f43a62fdc3965df486de8a0d32fe800963589c41b38946602a0dc535.41474958_f43a62fdc3965df486de8a0d32fe800963589c41b38946602a0dc535.41474958" 47 | -- >>> toUrlPiece $ OAssetPair {currencyAsset = GYLovelace, commodityAsset = GYToken "f43a62fdc3965df486de8a0d32fe800963589c41b38946602a0dc535" "AGIX"} 48 | -- "_f43a62fdc3965df486de8a0d32fe800963589c41b38946602a0dc535.41474958" 49 | instance ToHttpApiData OrderAssetPair where 50 | toUrlPiece OAssetPair {..} = toUrlPiece currencyAsset <> "_" <> toUrlPiece commodityAsset 51 | 52 | -- >>> parseUrlPiece "f43a62fdc3965df486de8a0d32fe800963589c41b38946602a0dc535.41474958_f43a62fdc3965df486de8a0d32fe800963589c41b38946602a0dc535.41474958" :: Either Text OrderAssetPair 53 | -- Right (OAssetPair {currencyAsset = GYToken "f43a62fdc3965df486de8a0d32fe800963589c41b38946602a0dc535" "AGIX", commodityAsset = GYToken "f43a62fdc3965df486de8a0d32fe800963589c41b38946602a0dc535" "AGIX"}) 54 | -- >>> parseUrlPiece "_f43a62fdc3965df486de8a0d32fe800963589c41b38946602a0dc535.41474958" :: Either Text OrderAssetPair 55 | -- Right (OAssetPair {currencyAsset = GYLovelace, commodityAsset = GYToken "f43a62fdc3965df486de8a0d32fe800963589c41b38946602a0dc535" "AGIX"}) 56 | -- >>> parseUrlPiece "f43a62fdc3965df486de8a0d32fe800963589c41b38946602a0dc535.41474958_" :: Either Text OrderAssetPair 57 | -- Right (OAssetPair {currencyAsset = GYToken "f43a62fdc3965df486de8a0d32fe800963589c41b38946602a0dc535" "AGIX", commodityAsset = GYLovelace}) 58 | -- >>> parseUrlPiece "_" :: Either Text OrderAssetPair 59 | -- Right (OAssetPair {currencyAsset = GYLovelace, commodityAsset = GYLovelace}) 60 | -- >>> parseUrlPiece "" :: Either Text OrderAssetPair 61 | -- Right (OAssetPair {currencyAsset = GYLovelace, commodityAsset = GYLovelace}) 62 | instance FromHttpApiData OrderAssetPair where 63 | parseUrlPiece t = do 64 | let (cur, com) = (\com' → if Text.null com' then com' else Text.drop 1 com') <$> Text.breakOn "_" t 65 | curAsset ← parseUrlPiece cur 66 | comAsset ← parseUrlPiece com 67 | pure $ OAssetPair curAsset comAsset 68 | 69 | instance Swagger.ToParamSchema OrderAssetPair where 70 | toParamSchema _ = 71 | mempty 72 | & Swagger.type_ 73 | ?~ Swagger.SwaggerString 74 | 75 | instance Swagger.ToSchema OrderAssetPair where 76 | declareNamedSchema p = 77 | pure 78 | $ Swagger.named "OrderAssetPair" 79 | $ Swagger.paramSchemaToSchema p 80 | & Swagger.example 81 | ?~ toJSON ("f43a62fdc3965df486de8a0d32fe800963589c41b38946602a0dc535.41474958_dda5fdb1002f7389b33e036b6afee82a8189becb6cba852e8b79b4fb.0014df1047454e53" ∷ String) 82 | & Swagger.description 83 | ?~ "Market pair identifier. It's an underscore delimited concatenation of offered and asked asset's \"token detail\". A token detail is given by dot delimited concatenation of policy id and token name." 84 | 85 | {- | Two order asset pairs are considered "equivalent" (but not strictly equal, as in 'Eq'), 86 | if they contain the same 2 assets irrespective of order. 87 | i.e {currencyAsset = A, commodityAsset = B} and 88 | {currencyAsset = B, commodityAsset = A} are equivalent. 89 | -} 90 | equivalentAssetPair ∷ OrderAssetPair → OrderAssetPair → Bool 91 | equivalentAssetPair oap oap' = oap == oap' || oap == mkEquivalentAssetPair oap' 92 | 93 | mkEquivalentAssetPair ∷ OrderAssetPair → OrderAssetPair 94 | mkEquivalentAssetPair oap = 95 | OAssetPair 96 | { commodityAsset = currencyAsset oap, 97 | currencyAsset = commodityAsset oap 98 | } 99 | 100 | mkOrderAssetPair 101 | ∷ GYAssetClass 102 | -- ^ Asset class of the currency asset in the order. 103 | → GYAssetClass 104 | -- ^ Asset class of the commodity asset in the order. 105 | → OrderAssetPair 106 | mkOrderAssetPair curAsset comAsset = 107 | OAssetPair 108 | { currencyAsset = curAsset, 109 | commodityAsset = comAsset 110 | } 111 | 112 | class HasMarkets a where 113 | getMarkets ∷ a → IO [OrderAssetPair] 114 | -------------------------------------------------------------------------------- /geniusyield-server-lib/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for geniusyield-server-lib 2 | 3 | ## 0.11.2 -- 2024-02-14 4 | 5 | * Update to Atlas v0.11.1. 6 | 7 | ## 0.11.1 -- 2024-10-30 8 | 9 | * Adds support of [`prices`](https://openapi.taptools.io/#tag/Market-Tokens/paths/~1token~1prices/post) TapTools endpoint. 10 | * In case project is being built from an environment which lacks access to corresponding `.git` directory, "UNKNOWN_REVISION" is used for `revision` field when querying for settings of the server. 11 | 12 | ## 0.11.0 -- 2024-08-30 13 | 14 | * Update to Atlas v0.6.0. 15 | 16 | ## 0.10.1 -- 2024-08-29 17 | 18 | * Updated Atlas & Maestro SDK version to not make use Maestro's recently deprecated protocol parameters & era summaries endpoint. 19 | 20 | ## 0.10.0 -- 2024-08-05 21 | 22 | * Fix the JSON/YAML configuration parser to require `addrIx`, `accIx` instead of `addr_ix`, `acc_ix` respectively. 23 | 24 | ## 0.9.0 -- 2024-07-16 25 | 26 | * Updates to latest commit of Atlas. Note that this update now requires GHC version to be 9.6.5. 27 | * Includes a fix for generated Open API specification where some of the schema objects were not represented appropriately. 28 | 29 | ## 0.8.0 -- 2024-07-09 30 | 31 | * Updates `/v0/orders/fill` and `/v0/orders/tx/build-fill` endpoint to internally call `fillPartialOrder'` instead of `fillMultiplePartialOrders'` when single order is being filled. 32 | * Updates `/v0/order-books/{market-id}` endpoint to also return for `offer_amount_in_datum`, `price_in_datum` and `version`. 33 | 34 | ## 0.7.0 -- 2024-06-26 35 | 36 | * Updates `fotdTakerOfferedPercentFeeAmount` field of response of `/v0/orders/fill` and `/v0/orders/tx/build-fill` to now return bag of tokens in which taker fee is charged. These two endpoints now also supports filling of payment tokens where not all of them belong to same pair. 37 | 38 | ## 0.6.0 -- 2024-06-10 39 | 40 | * Makes a move to OpenApi 3.0 specification from earlier 2.0. 41 | 42 | ## 0.5.1 -- 2024-06-06 43 | 44 | * Incorporates 0.3.1.0 of `geniusyield-dex-api`. 45 | 46 | ## 0.5.0 -- 2024-06-05 47 | 48 | * Makes use of latest `geniusyield-dex-api` version, namely, v0.3.0.0. It includes a fix where original UTxO's datum bytes are used to provide for witness. 49 | 50 | ## 0.4.1 -- 2024-05-28 51 | 52 | * Fix `/v0/orders/fill` endpoint to account for case when percent taker fees is zero. 53 | 54 | ## 0.4.0 -- 2024-05-20 55 | 56 | * Fix response of GET `/v0/orders/details/{nft-token}` endpoint to not return response under a `data` field nesting. 57 | * Added `/v0/orders/fill` endpoint. 58 | 59 | ## 0.3.0 -- 2024-05-07 60 | 61 | * Adds TapTools OHLCV endpoint. 62 | * Adds NFT token in response of place order family of endpoints. 63 | * Adds GET variant for getting details of an order from it's NFT token identifier. 64 | * Clarifies which endpoints require `maestroToken` field to be set. 65 | * Clarifies which endpoints require signing key to be configured in the server to derive for wallet's address, likewise it is clarified that which endpoints use fields such as `collateral`, etc. from server's configuration. 66 | 67 | ## 0.2.0 -- 2024-04-22 68 | 69 | * Uses latest version of `geniusyield-dex-api` which adds support of v1.1 script. 70 | * `settings` endpoint now returns `genius-server` instead of `mmb` as return value of `backend` field. 71 | 72 | ## 0.1.0 -- 2024-04-02 73 | 74 | * First version. 75 | -------------------------------------------------------------------------------- /geniusyield-server-lib/README.md: -------------------------------------------------------------------------------- 1 | # GeniusYield API Server 2 | 3 | Library used to serve API endpoints in relation to GeniusYield DEX. -------------------------------------------------------------------------------- /geniusyield-server-lib/app/Main.hs: -------------------------------------------------------------------------------- 1 | import GeniusYield.Server.Options 2 | import Options.Applicative 3 | import RIO 4 | 5 | main ∷ IO () 6 | main = runCommand =<< execParser opts 7 | where 8 | opts = 9 | info 10 | (parseCommand <**> helper) 11 | ( fullDesc 12 | <> progDesc "GeniusYield DEX helpful operations" 13 | <> header "GeniusYield DEX" 14 | ) 15 | -------------------------------------------------------------------------------- /geniusyield-server-lib/geniusyield-server-lib.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.12 2 | name: geniusyield-server-lib 3 | version: 0.11.2 4 | synopsis: GeniusYield server library 5 | description: Library for GeniusYield server. 6 | license: Apache-2.0 7 | license-file: LICENSE 8 | bug-reports: http://github.com/geniusyield/dex-contracts-api/issues 9 | author: GeniusYield 10 | maintainer: support@geniusyield.co 11 | copyright: 2024 GYELD GMBH 12 | build-type: Simple 13 | category: Blockchain, Cardano 14 | extra-doc-files: 15 | CHANGELOG.md 16 | README.md 17 | 18 | tested-with: GHC ==9.6.5 19 | 20 | source-repository head 21 | type: git 22 | location: https://github.com/geniusyield/dex-contracts-api.git 23 | 24 | common common 25 | default-language: GHC2021 26 | default-extensions: 27 | NoImplicitPrelude 28 | DataKinds 29 | DeriveAnyClass 30 | DerivingStrategies 31 | DerivingVia 32 | GADTs 33 | LambdaCase 34 | MultiWayIf 35 | OverloadedStrings 36 | RecordWildCards 37 | RoleAnnotations 38 | TemplateHaskell 39 | TypeFamilies 40 | TypeFamilyDependencies 41 | UndecidableInstances 42 | UnicodeSyntax 43 | ViewPatterns 44 | 45 | ghc-options: -Wall -Wincomplete-uni-patterns -Wunused-packages 46 | 47 | -- Speed-ups GHCi considerably. 48 | ghc-options: -fno-show-valid-hole-fits 49 | 50 | library 51 | import: common 52 | hs-source-dirs: src 53 | exposed-modules: 54 | GeniusYield.Server.Api 55 | GeniusYield.Server.Assets 56 | GeniusYield.Server.Auth 57 | GeniusYield.Server.Config 58 | GeniusYield.Server.Constants 59 | GeniusYield.Server.Ctx 60 | GeniusYield.Server.Dex.HistoricalPrices.Maestro 61 | GeniusYield.Server.Dex.HistoricalPrices.TapTools 62 | GeniusYield.Server.Dex.HistoricalPrices.TapTools.Client 63 | GeniusYield.Server.Dex.Markets 64 | GeniusYield.Server.Dex.PartialOrder 65 | GeniusYield.Server.ErrorMiddleware 66 | GeniusYield.Server.Options 67 | GeniusYield.Server.Orphans 68 | GeniusYield.Server.RequestLoggerMiddleware 69 | GeniusYield.Server.Run 70 | GeniusYield.Server.Tx 71 | GeniusYield.Server.Utils 72 | 73 | other-modules: 74 | PackageInfo_geniusyield_server_lib 75 | Paths_geniusyield_server_lib 76 | 77 | autogen-modules: 78 | Paths_geniusyield_server_lib 79 | PackageInfo_geniusyield_server_lib 80 | 81 | build-depends: 82 | , aeson 83 | , atlas-cardano 84 | , base ^>=4.18.2.0 85 | , binary 86 | , bytestring 87 | , cardano-api 88 | , containers 89 | , deriving-aeson 90 | , envy 91 | , fast-logger 92 | , fmt 93 | , geniusyield-dex-api 94 | , geniusyield-orderbot-lib 95 | , githash 96 | , http-client 97 | , http-client-tls 98 | , http-types 99 | , insert-ordered-containers 100 | , lens 101 | , openapi3 102 | , optparse-applicative 103 | , rio 104 | , servant 105 | , servant-client 106 | , servant-client-core 107 | , servant-openapi3 108 | , servant-foreign 109 | , servant-server 110 | , strict 111 | , swagger2 112 | , time 113 | , time-manager 114 | , transformers 115 | , wai 116 | , wai-extra 117 | , warp 118 | , yaml 119 | 120 | -- Dependencies whose version is fixed by @cabal.project@ file. 121 | build-depends: 122 | , atlas-cardano 123 | , maestro-sdk 124 | 125 | executable geniusyield-server 126 | import: common 127 | hs-source-dirs: app 128 | main-is: Main.hs 129 | ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-T 130 | build-depends: 131 | , geniusyield-server-lib 132 | , optparse-applicative 133 | , rio 134 | -------------------------------------------------------------------------------- /geniusyield-server-lib/src/GeniusYield/Server/Assets.hs: -------------------------------------------------------------------------------- 1 | module GeniusYield.Server.Assets ( 2 | AssetsAPI, 3 | handleAssetsApi, 4 | ) where 5 | 6 | import Fmt 7 | import GHC.TypeLits (AppendSymbol) 8 | import GeniusYield.OrderBot.Domain.Assets 9 | import GeniusYield.Server.Ctx 10 | import GeniusYield.Server.Utils 11 | import GeniusYield.Types 12 | import RIO hiding (logDebug, logInfo) 13 | import Servant 14 | 15 | type AssetsAPI = Summary "Get assets information" :> Description ("Get information for a specific asset. " `AppendSymbol` CommonMaestroKeyRequirementText) :> Capture "asset" GYAssetClass :> Get '[JSON] AssetDetails 16 | 17 | handleAssetsApi ∷ Ctx → GYAssetClass → IO AssetDetails 18 | handleAssetsApi ctx@Ctx {..} ac = do 19 | logInfo ctx $ "Fetching details of asset: " +|| ac ||+ "" 20 | getAssetDetails ctxMaestroProvider ac 21 | -------------------------------------------------------------------------------- /geniusyield-server-lib/src/GeniusYield/Server/Auth.hs: -------------------------------------------------------------------------------- 1 | module GeniusYield.Server.Auth ( 2 | V0, 3 | ApiKey, 4 | apiKeyFromText, 5 | ApiKeyHeader, 6 | apiKeyHeaderText, 7 | apiKeyAuthHandler, 8 | APIKeyAuthProtect, 9 | ) where 10 | 11 | import GHC.TypeLits (Symbol, symbolVal) 12 | import Network.Wai (Request (requestHeaders)) 13 | import RIO 14 | import RIO.Text qualified as T 15 | import Servant 16 | import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler) 17 | 18 | type V0 ∷ Symbol 19 | type V0 = "v0" 20 | 21 | -- | The Api Key type. 22 | newtype ApiKey = ApiKey ByteString 23 | 24 | apiKeyFromText ∷ Text → ApiKey 25 | apiKeyFromText = ApiKey . encodeUtf8 26 | 27 | type ApiKeyHeader ∷ Symbol 28 | type ApiKeyHeader = "api-key" 29 | 30 | apiKeyHeaderText ∷ Text 31 | apiKeyHeaderText = symbolVal (Proxy ∷ Proxy ApiKeyHeader) & T.pack 32 | 33 | apiKeyAuthHandler ∷ ApiKey → AuthHandler Request () 34 | apiKeyAuthHandler (ApiKey key) = mkAuthHandler handler 35 | where 36 | handler req = case lookup "api-key" (requestHeaders req) of 37 | Nothing → throwError err401 {errBody = "Missing API key (please pass the api key in the api-key HTTP header)"} 38 | Just key' → 39 | if key' == key 40 | then pure () 41 | else throwError err403 {errBody = "Invalid API key"} 42 | 43 | type APIKeyAuthProtect = AuthProtect ApiKeyHeader 44 | 45 | type instance AuthServerData APIKeyAuthProtect = () 46 | -------------------------------------------------------------------------------- /geniusyield-server-lib/src/GeniusYield/Server/Config.hs: -------------------------------------------------------------------------------- 1 | module GeniusYield.Server.Config ( 2 | ServerConfig (..), 3 | serverConfigOptionalFPIO, 4 | coreConfigFromServerConfig, 5 | optionalSigningKeyFromServerConfig, 6 | ) where 7 | 8 | import Cardano.Api qualified as Api 9 | import Data.Aeson ( 10 | eitherDecodeFileStrict, 11 | eitherDecodeStrict, 12 | ) 13 | import Data.Strict.Tuple (Pair (..)) 14 | import Data.Yaml qualified as Yaml 15 | import Deriving.Aeson 16 | import GHC.IO.Exception (userError) 17 | import GeniusYield.GYConfig (Confidential, GYCoreConfig (..), GYCoreProviderInfo) 18 | import GeniusYield.Types hiding (Port) 19 | import Maestro.Types.Common (LowerFirst) 20 | import Network.Wai.Handler.Warp (Port) 21 | import RIO 22 | import RIO.FilePath (takeExtension) 23 | import System.Envy 24 | import Unsafe.Coerce (unsafeCoerce) 25 | 26 | {- $setup 27 | 28 | >>> :set -XOverloadedStrings -XTypeApplications 29 | >>> import qualified Data.Aeson as Aeson 30 | >>> import qualified Data.ByteString.Lazy.Char8 as LBS8 31 | >>> import Data.Proxy 32 | -} 33 | 34 | -- >>> Aeson.encode (MnemonicWallet (MnemonicWalletDetails ["hello"] (Just 1) (Just 2))) 35 | -- "{\"tag\":\"mnemonicWallet\",\"contents\":{\"mnemonic\":[\"hello\"],\"acc_ix\":1,\"addr_ix\":2}}" 36 | data UserWallet = MnemonicWallet !MnemonicWalletDetails | KeyPathWallet !FilePath 37 | deriving stock (Generic) 38 | deriving (FromJSON, ToJSON) via CustomJSON '[ConstructorTagModifier '[LowerFirst]] UserWallet 39 | 40 | data MnemonicWalletDetails = MnemonicWalletDetails 41 | { -- | Mnemonic (seed phrase). 42 | mnemonic ∷ !Mnemonic, 43 | -- | Account index. 44 | accIx ∷ !(Maybe Word32), 45 | -- | Payment address index. 46 | addrIx ∷ !(Maybe Word32) 47 | } 48 | deriving stock (Generic) 49 | deriving anyclass (FromJSON, ToJSON) 50 | 51 | data ServerConfig = ServerConfig 52 | { scCoreProvider ∷ !GYCoreProviderInfo, 53 | scNetworkId ∷ !GYNetworkId, 54 | scLogging ∷ ![GYLogScribeConfig], 55 | scMaestroToken ∷ !(Confidential Text), 56 | scPort ∷ !Port, 57 | scWallet ∷ !(Maybe UserWallet), 58 | scServerApiKey ∷ !(Confidential Text), 59 | scTapToolsApiKey ∷ !(Maybe (Confidential Text)), 60 | scCollateral ∷ !(Maybe GYTxOutRef), 61 | scStakeAddress ∷ !(Maybe GYStakeAddressBech32) 62 | } 63 | deriving stock (Generic) 64 | deriving 65 | (FromJSON) 66 | via CustomJSON '[FieldLabelModifier '[StripPrefix "sc", LowerFirst]] ServerConfig 67 | 68 | instance FromEnv ServerConfig where 69 | fromEnv _ = forceFromJsonOrYaml <$> env "SERVER_CONFIG" 70 | where 71 | forceFromJsonOrYaml ∷ FromJSON a ⇒ String → a 72 | forceFromJsonOrYaml s = 73 | let bs = fromString s 74 | parseResults = eitherDecodeStrict bs :| [first show $ Yaml.decodeEither' bs] 75 | in go parseResults 76 | where 77 | go (x :| []) = case x of 78 | Left e → error e 79 | Right a → a 80 | go (x :| y : ys) = case x of 81 | Left _ → go (y :| ys) 82 | Right a → a 83 | 84 | eitherDecodeFileStrictJsonOrYaml ∷ FromJSON a ⇒ FilePath → IO (Either String a) 85 | eitherDecodeFileStrictJsonOrYaml fp = 86 | case takeExtension fp of 87 | ".json" → eitherDecodeFileStrict fp 88 | ".yaml" → first show <$> Yaml.decodeFileEither fp 89 | _ → throwIO $ userError "Only .json or .yaml extensions are supported for configuration." 90 | 91 | serverConfigOptionalFPIO ∷ Maybe FilePath → IO ServerConfig 92 | serverConfigOptionalFPIO mfp = do 93 | e ← maybe decodeEnv eitherDecodeFileStrictJsonOrYaml mfp 94 | either (throwIO . userError) return e 95 | 96 | coreConfigFromServerConfig ∷ ServerConfig → GYCoreConfig 97 | coreConfigFromServerConfig ServerConfig {..} = 98 | GYCoreConfig 99 | { cfgCoreProvider = scCoreProvider, 100 | cfgNetworkId = scNetworkId, 101 | cfgLogging = scLogging, 102 | cfgLogTiming = Nothing 103 | } 104 | 105 | optionalSigningKeyFromServerConfig ∷ ServerConfig → IO (Maybe (Pair GYSomePaymentSigningKey GYAddress)) 106 | optionalSigningKeyFromServerConfig ServerConfig {..} = do 107 | case scWallet of 108 | Nothing → pure Nothing 109 | Just (MnemonicWallet MnemonicWalletDetails {..}) → 110 | let wk' = walletKeysFromMnemonicIndexed mnemonic (fromMaybe 0 accIx) (fromMaybe 0 addrIx) 111 | in pure $ case wk' of 112 | Left _ → Nothing 113 | Right wk → Just (AGYExtendedPaymentSigningKey (walletKeysToExtendedPaymentSigningKey wk) :!: walletKeysToAddress wk scNetworkId) 114 | Just (KeyPathWallet fp) → do 115 | skey ← readSomePaymentSigningKey fp 116 | pure $ Just (skey :!: addressFromSomePaymentSigningKey scNetworkId skey) 117 | where 118 | addressFromSomePaymentSigningKey ∷ GYNetworkId → GYSomePaymentSigningKey → GYAddress 119 | addressFromSomePaymentSigningKey nid skey = 120 | let pkh = 121 | case skey of 122 | AGYPaymentSigningKey skey' → paymentKeyHash . paymentVerificationKey $ skey' 123 | AGYExtendedPaymentSigningKey skey' → extendedPaymentSigningKeyToApi skey' & Api.getVerificationKey & Api.verificationKeyHash & unsafeCoerce & paymentKeyHashFromApi -- Usage of `unsafeCoerce` here as Atlas's key hash types need an overhaul since it is not powerful enough to cater for all the relevant cases. 124 | in addressFromPaymentKeyHash nid pkh 125 | -------------------------------------------------------------------------------- /geniusyield-server-lib/src/GeniusYield/Server/Constants.hs: -------------------------------------------------------------------------------- 1 | module GeniusYield.Server.Constants ( 2 | module GeniusYield.Api.Dex.Constants, 3 | gitHash, 4 | ) where 5 | 6 | import GeniusYield.Api.Dex.Constants 7 | import GitHash 8 | import RIO 9 | 10 | -- | The git hash of the current commit. 11 | gitHash ∷ String 12 | gitHash = either (const "UNKNOWN_REVISION") giHash $$tGitInfoCwdTry 13 | -------------------------------------------------------------------------------- /geniusyield-server-lib/src/GeniusYield/Server/Ctx.hs: -------------------------------------------------------------------------------- 1 | module GeniusYield.Server.Ctx ( 2 | DEXInfo (..), 3 | dexInfoDefaultMainnet, 4 | dexInfoDefaultPreprod, 5 | TapToolsApiKey, 6 | TapToolsEnv (..), 7 | Ctx (..), 8 | runSkeletonI, 9 | runSkeletonWithStrategyI, 10 | runSkeletonF, 11 | runSkeletonWithStrategyF, 12 | runQuery, 13 | runQueryWithReader, 14 | ) where 15 | 16 | import Data.Strict.Tuple (Pair (..)) 17 | import GeniusYield.Imports 18 | import GeniusYield.OrderBot.Adapter.Maestro (MaestroProvider) 19 | import GeniusYield.Server.Constants (DEXInfo (..), dexInfoDefaultMainnet, dexInfoDefaultPreprod) 20 | import GeniusYield.Transaction 21 | import GeniusYield.TxBuilder 22 | import GeniusYield.Types 23 | import RIO 24 | import Servant.Client (ClientEnv) 25 | 26 | type TapToolsApiKey = Text 27 | 28 | data TapToolsEnv = TapToolsEnv 29 | { tteClientEnv ∷ !ClientEnv, 30 | tteApiKey ∷ !TapToolsApiKey 31 | } 32 | 33 | -- | Server context: configuration & shared state. 34 | data Ctx = Ctx 35 | { ctxNetworkId ∷ !GYNetworkId, 36 | ctxProviders ∷ !GYProviders, 37 | ctxDexInfo ∷ !DEXInfo, 38 | ctxMaestroProvider ∷ !MaestroProvider, 39 | ctxTapToolsProvider ∷ !(Maybe TapToolsEnv), 40 | ctxSigningKey ∷ !(Maybe (Pair GYSomePaymentSigningKey GYAddress)), 41 | ctxCollateral ∷ !(Maybe GYTxOutRef), 42 | ctxStakeAddress ∷ !(Maybe GYStakeAddressBech32) 43 | } 44 | 45 | -- | Create 'TxBody' from a 'GYTxSkeleton'. 46 | runSkeletonI 47 | ∷ Ctx 48 | → [GYAddress] 49 | -- ^ User's used addresses. Note that internally we prepend given change address to this list so that in case wallet's state isn't updated quickly to mark an earlier given change address as used, we'll be able to use UTxOs potentially present at this change address. 50 | → GYAddress 51 | -- ^ User's change address. 52 | → Maybe GYTxOutRef 53 | -- ^ User's collateral. 54 | → ReaderT DEXInfo GYTxBuilderMonadIO (GYTxSkeleton v) 55 | → IO GYTxBody 56 | runSkeletonI = coerce (runSkeletonF @Identity) 57 | 58 | -- | Create 'TxBody' from a 'GYTxSkeleton', with the specified coin selection strategy. 59 | runSkeletonWithStrategyI 60 | ∷ GYCoinSelectionStrategy 61 | → Ctx 62 | → [GYAddress] 63 | -- ^ User's used addresses. Note that internally we prepend given change address to this list so that in case wallet's state isn't updated quickly to mark an earlier given change address as used, we'll be able to use UTxOs potentially present at this change address. 64 | → GYAddress 65 | -- ^ User's change address. 66 | → Maybe GYTxOutRef 67 | -- ^ User's collateral. 68 | → ReaderT DEXInfo GYTxBuilderMonadIO (GYTxSkeleton v) 69 | → IO GYTxBody 70 | runSkeletonWithStrategyI cstrat = coerce (runSkeletonWithStrategyF @Identity cstrat) 71 | 72 | runSkeletonF 73 | ∷ Traversable t 74 | ⇒ Ctx 75 | → [GYAddress] 76 | -- ^ User's used addresses. Note that internally we prepend given change address to this list so that in case wallet's state isn't updated quickly to mark an earlier given change address as used, we'll be able to use UTxOs potentially present at this change address. 77 | → GYAddress 78 | -- ^ User's change address. 79 | → Maybe GYTxOutRef 80 | -- ^ User's collateral. 81 | → ReaderT DEXInfo GYTxBuilderMonadIO (t (GYTxSkeleton v)) 82 | → IO (t GYTxBody) 83 | runSkeletonF = runSkeletonWithStrategyF GYRandomImproveMultiAsset 84 | 85 | runSkeletonWithStrategyF 86 | ∷ Traversable t 87 | ⇒ GYCoinSelectionStrategy 88 | → Ctx 89 | → [GYAddress] 90 | -- ^ User's used addresses. Note that internally we prepend given change address to this list so that in case wallet's state isn't updated quickly to mark an earlier given change address as used, we'll be able to use UTxOs potentially present at this change address. 91 | → GYAddress 92 | -- ^ User's change address. 93 | → Maybe GYTxOutRef 94 | -- ^ User's collateral. 95 | → ReaderT DEXInfo GYTxBuilderMonadIO (t (GYTxSkeleton v)) 96 | → IO (t GYTxBody) 97 | runSkeletonWithStrategyF cstrat ctx addrs addr mcollateral skeleton = do 98 | let nid = ctxNetworkId ctx 99 | providers = ctxProviders ctx 100 | di = ctxDexInfo ctx 101 | mcollateral' = do 102 | collateral ← mcollateral 103 | pure (collateral, False) 104 | 105 | runGYTxMonadNodeF cstrat nid providers (addr : addrs) addr mcollateral' $ runReaderT skeleton di 106 | 107 | runQuery ∷ Ctx → ReaderT DEXInfo GYTxQueryMonadIO a → IO a 108 | runQuery ctx = runQueryWithReader ctx (ctxDexInfo ctx) 109 | 110 | runQueryWithReader ∷ Ctx → a → ReaderT a GYTxQueryMonadIO b → IO b 111 | runQueryWithReader ctx a q = do 112 | let nid = ctxNetworkId ctx 113 | providers = ctxProviders ctx 114 | runGYTxQueryMonadIO nid providers $ runReaderT q a 115 | 116 | runGYTxMonadNodeF ∷ ∀ t v. Traversable t ⇒ GYCoinSelectionStrategy → GYNetworkId → GYProviders → [GYAddress] → GYAddress → Maybe (GYTxOutRef, Bool) → GYTxBuilderMonadIO (t (GYTxSkeleton v)) → IO (t GYTxBody) 117 | runGYTxMonadNodeF strat nid providers addrs change collateral act = runGYTxBuilderMonadIO nid providers addrs change collateral $ act >>= traverse (buildTxBodyWithStrategy strat) 118 | -------------------------------------------------------------------------------- /geniusyield-server-lib/src/GeniusYield/Server/Dex/HistoricalPrices/TapTools.hs: -------------------------------------------------------------------------------- 1 | module GeniusYield.Server.Dex.HistoricalPrices.TapTools ( 2 | TapToolsPriceHistoryAPI, 3 | handleTapToolsPriceHistoryApi, 4 | ) where 5 | 6 | import Control.Lens ((?~)) 7 | import Data.Swagger qualified as Swagger 8 | import Data.Swagger.Internal.Schema qualified as Swagger 9 | import Fmt 10 | import GeniusYield.Server.Ctx 11 | import GeniusYield.Server.Dex.HistoricalPrices.TapTools.Client (TapToolsInterval, TapToolsOHLCV, TapToolsUnit (TapToolsUnit), handleTapToolsError, tapToolsOHLCV) 12 | import GeniusYield.Server.Utils 13 | import GeniusYield.Types 14 | import RIO hiding (logDebug, logInfo) 15 | import Servant 16 | 17 | newtype TapToolsNumIntervals = TapToolsNumIntervals {unTapToolsNumIntervals ∷ Natural} 18 | deriving stock (Eq, Ord, Show) 19 | deriving newtype (FromHttpApiData, Swagger.ToParamSchema) 20 | 21 | -- Since this is a query parameter, our schema description wouldn't be registered for in swagger specification :(. Following OpenAPI 3.0 would allow for it. 22 | instance Swagger.ToSchema TapToolsNumIntervals where 23 | declareNamedSchema p = 24 | pure 25 | $ Swagger.named "TapToolsNumIntervals" 26 | $ Swagger.paramSchemaToSchema p 27 | & Swagger.description 28 | ?~ "The number of intervals to return, e.g. if you want 180 days of data in 1d intervals, then pass 180 here." 29 | 30 | type TapToolsPriceHistoryAPI = 31 | Summary "Get price history using TapTools." 32 | :> Description "This endpoint internally calls TapTools's \"Token price OHLCV\" endpoint. Note that only the liquidity pools involving ADA and the given asset class is considered to get for aggregated price information. Price returned is in ADA." 33 | :> Capture "asset" GYAssetClass 34 | :> QueryParam' '[Required, Strict] "interval" TapToolsInterval 35 | :> QueryParam "numIntervals" TapToolsNumIntervals 36 | :> Get '[JSON] [TapToolsOHLCV] 37 | 38 | throwNoTapToolsKeyError ∷ IO a 39 | throwNoTapToolsKeyError = throwIO $ err500 {errBody = "No API key configured for TapTools."} 40 | 41 | handleTapToolsPriceHistoryApi ∷ Ctx → GYAssetClass → TapToolsInterval → Maybe TapToolsNumIntervals → IO [TapToolsOHLCV] 42 | handleTapToolsPriceHistoryApi ctx token tti (fmap unTapToolsNumIntervals → mttni) = do 43 | logInfo ctx $ "Fetching price history. Token: " +|| token ||+ ", interval: " +|| tti ||+ "" 44 | case ctxTapToolsProvider ctx of 45 | Nothing → throwNoTapToolsKeyError 46 | Just te → try (tapToolsOHLCV te (Just (TapToolsUnit token)) tti mttni) >>= handleTapToolsError "handleTapToolsPriceHistory" 47 | -------------------------------------------------------------------------------- /geniusyield-server-lib/src/GeniusYield/Server/Dex/HistoricalPrices/TapTools/Client.hs: -------------------------------------------------------------------------------- 1 | module GeniusYield.Server.Dex.HistoricalPrices.TapTools.Client ( 2 | TapToolsUnit (..), 3 | TapToolsInterval (..), 4 | TapToolsOHLCV (..), 5 | TapToolsAPI, 6 | TapToolsOHLCVAPI, 7 | tapToolsClientEnv, 8 | tapToolsOHLCV, 9 | tapToolsPrices, 10 | PricesResponse, 11 | TapToolsException, 12 | handleTapToolsError, 13 | ) where 14 | 15 | import Control.Lens ((?~)) 16 | import Data.Aeson (ToJSON (..)) 17 | import Data.Aeson qualified as Aeson 18 | import Data.Aeson.Types qualified as Aeson 19 | import Data.Map.Strict qualified as Map 20 | import Data.Swagger qualified as Swagger 21 | import Data.Time.Clock.POSIX 22 | import Deriving.Aeson 23 | import GHC.TypeLits (Symbol, symbolVal) 24 | import GeniusYield.Server.Ctx (TapToolsApiKey, TapToolsEnv (tteApiKey, tteClientEnv)) 25 | import GeniusYield.Server.Utils (commonEnumParamSchemaRecipe, hideServantClientErrorHeader) 26 | import GeniusYield.Swagger.Utils 27 | import GeniusYield.Types (GYAssetClass, makeAssetClass) 28 | import Maestro.Types.Common (LowerFirst) 29 | import Network.HTTP.Client (newManager) 30 | import Network.HTTP.Client.TLS (tlsManagerSettings) 31 | import RIO 32 | import RIO.Text qualified as Text 33 | import Servant.API 34 | import Servant.Client 35 | 36 | {- $setup 37 | 38 | >>> :set -XOverloadedStrings -XTypeApplications 39 | >>> import GeniusYield.Types 40 | -} 41 | 42 | newtype TapToolsUnit = TapToolsUnit {unTapToolsUnit ∷ GYAssetClass} 43 | deriving stock (Eq, Ord, Show) 44 | 45 | {- | 46 | 47 | >>> toUrlPiece $ TapToolsUnit "dda5fdb1002f7389b33e036b6afee82a8189becb6cba852e8b79b4fb.0014df1047454e53" 48 | "dda5fdb1002f7389b33e036b6afee82a8189becb6cba852e8b79b4fb0014df1047454e53" 49 | -} 50 | instance ToHttpApiData TapToolsUnit where 51 | toUrlPiece (TapToolsUnit ac) = removeDot $ toUrlPiece ac 52 | where 53 | removeDot = Text.filter (/= '.') 54 | 55 | instance Aeson.ToJSON TapToolsUnit where 56 | toJSON = Aeson.toJSON . toUrlPiece 57 | 58 | instance Aeson.ToJSONKey TapToolsUnit where 59 | toJSONKey = Aeson.toJSONKeyText toUrlPiece 60 | 61 | instance FromHttpApiData TapToolsUnit where 62 | parseUrlPiece t = 63 | let (pid, tn) = Text.splitAt 56 t 64 | in bimap Text.pack TapToolsUnit $ makeAssetClass pid tn 65 | 66 | instance Aeson.FromJSON TapToolsUnit where 67 | parseJSON = Aeson.withText "TapToolsUnit" $ \t → case parseUrlPiece t of 68 | Left e → fail $ show e 69 | Right ttu → pure ttu 70 | 71 | instance Aeson.FromJSONKey TapToolsUnit where 72 | fromJSONKey = Aeson.FromJSONKeyTextParser (either (fail . show) pure . parseUrlPiece) 73 | 74 | data TapToolsInterval = TTI3m | TTI5m | TTI15m | TTI30m | TTI1h | TTI2h | TTI4h | TTI12h | TTI1d | TTI3d | TTI1w | TTI1M 75 | deriving stock (Eq, Ord, Enum, Bounded, Data, Typeable, Generic) 76 | deriving (FromJSON, ToJSON) via CustomJSON '[ConstructorTagModifier '[StripPrefix "TTI"]] TapToolsInterval 77 | 78 | -- >>> show TTI1M 79 | -- "1M" 80 | instance Show TapToolsInterval where 81 | show = toConstr >>> show >>> drop 3 82 | 83 | instance ToHttpApiData TapToolsInterval where 84 | toQueryParam = Text.pack . show 85 | 86 | instance FromHttpApiData TapToolsInterval where 87 | parseQueryParam = \case 88 | "3m" → Right TTI3m 89 | "5m" → Right TTI5m 90 | "15m" → Right TTI15m 91 | "30m" → Right TTI30m 92 | "1h" → Right TTI1h 93 | "2h" → Right TTI2h 94 | "4h" → Right TTI4h 95 | "12h" → Right TTI12h 96 | "1d" → Right TTI1d 97 | "3d" → Right TTI3d 98 | "1w" → Right TTI1w 99 | "1M" → Right TTI1M 100 | x → Left $ "Invalid TapToolsInterval: " <> x 101 | 102 | instance Swagger.ToParamSchema TapToolsInterval where 103 | toParamSchema = commonEnumParamSchemaRecipe 104 | 105 | instance Swagger.ToSchema TapToolsInterval where 106 | declareNamedSchema p = 107 | pure 108 | $ Swagger.NamedSchema (Just "TapToolsInterval") 109 | $ Swagger.paramSchemaToSchema p 110 | & Swagger.example 111 | ?~ toJSON TTI1M 112 | & Swagger.description 113 | ?~ "The time interval" 114 | 115 | type TapToolsOHLCVPrefix ∷ Symbol 116 | type TapToolsOHLCVPrefix = "tapToolsOHLCV" 117 | 118 | data TapToolsOHLCV = TapToolsOHLCV 119 | { tapToolsOHLCVTime ∷ !POSIXTime, 120 | tapToolsOHLCVOpen ∷ !Double, 121 | tapToolsOHLCVHigh ∷ !Double, 122 | tapToolsOHLCVLow ∷ !Double, 123 | tapToolsOHLCVClose ∷ !Double, 124 | tapToolsOHLCVVolume ∷ !Double 125 | } 126 | deriving stock (Eq, Ord, Show, Generic) 127 | deriving 128 | (FromJSON, ToJSON) 129 | via CustomJSON '[FieldLabelModifier '[StripPrefix TapToolsOHLCVPrefix, LowerFirst]] TapToolsOHLCV 130 | 131 | instance Swagger.ToSchema TapToolsOHLCV where 132 | declareNamedSchema = 133 | let open = 0.15800583264941748 134 | in Swagger.genericDeclareNamedSchema Swagger.defaultSchemaOptions {Swagger.fieldLabelModifier = dropSymbolAndCamelToSnake @TapToolsOHLCVPrefix} 135 | & addSwaggerDescription "Get a specific token's trended (open, high, low, close, volume) price data." 136 | & addSwaggerExample (toJSON $ TapToolsOHLCV {tapToolsOHLCVTime = 1_715_007_300, tapToolsOHLCVOpen = open, tapToolsOHLCVHigh = open, tapToolsOHLCVLow = open, tapToolsOHLCVClose = open, tapToolsOHLCVVolume = 120}) 137 | 138 | type PricesResponse = Map.Map TapToolsUnit Double 139 | 140 | type TapToolsApiKeyHeaderName ∷ Symbol 141 | type TapToolsApiKeyHeaderName = "x-api-key" 142 | 143 | type TapToolsAPI = 144 | Header' '[Required] TapToolsApiKeyHeaderName TapToolsApiKey 145 | :> "token" 146 | :> (TapToolsOHLCVAPI :<|> TapToolsPricesAPI) 147 | 148 | type TapToolsOHLCVAPI = 149 | "ohlcv" 150 | :> QueryParam "unit" TapToolsUnit 151 | :> QueryParam' '[Required, Strict] "interval" TapToolsInterval 152 | :> QueryParam "numIntervals" Natural 153 | :> Get '[JSON] [TapToolsOHLCV] 154 | 155 | type TapToolsPricesAPI = "prices" :> ReqBody '[JSON] [TapToolsUnit] :> Post '[JSON] PricesResponse 156 | 157 | data TapToolsClient = TapToolsClient 158 | { tapToolsOHLCVClient ∷ Maybe TapToolsUnit → TapToolsInterval → Maybe Natural → ClientM [TapToolsOHLCV], 159 | tapToolsPricesClient ∷ [TapToolsUnit] → ClientM PricesResponse 160 | } 161 | 162 | mkTapToolsClient ∷ TapToolsApiKey → TapToolsClient 163 | mkTapToolsClient apiKey = 164 | let tapToolsOHLCVClient :<|> tapToolsPricesClient = client (Proxy @TapToolsAPI) apiKey 165 | in TapToolsClient {..} 166 | 167 | tapToolsBaseUrl ∷ String 168 | tapToolsBaseUrl = "https://openapi.taptools.io/api/v1" 169 | 170 | tapToolsClientEnv ∷ IO ClientEnv 171 | tapToolsClientEnv = do 172 | baseUrl ← parseBaseUrl tapToolsBaseUrl 173 | manager ← newManager tlsManagerSettings 174 | pure $ mkClientEnv manager baseUrl 175 | 176 | runTapToolsClient ∷ TapToolsEnv → ClientM a → IO (Either ClientError a) 177 | runTapToolsClient (tteClientEnv → ce) c = runClientM c ce 178 | 179 | -- | Exceptions. 180 | data TapToolsException 181 | = -- | Error from the TapTools API. 182 | TapToolsApiError !Text !ClientError 183 | deriving stock (Eq, Show) 184 | deriving anyclass (Exception) 185 | 186 | handleTapToolsError ∷ Text → Either ClientError a → IO a 187 | handleTapToolsError locationInfo = either (throwIO . TapToolsApiError locationInfo . hideServantClientErrorHeader (fromString $ symbolVal (Proxy @TapToolsApiKeyHeaderName))) pure 188 | 189 | tapToolsOHLCV ∷ TapToolsEnv → Maybe TapToolsUnit → TapToolsInterval → Maybe Natural → IO [TapToolsOHLCV] 190 | tapToolsOHLCV env@(tteApiKey → apiKey) ttu tti mttni = mkTapToolsClient apiKey & tapToolsOHLCVClient & (\f → f ttu tti mttni) & runTapToolsClient env >>= handleTapToolsError "tapToolsOHLCV" 191 | 192 | tapToolsPrices ∷ TapToolsEnv → [TapToolsUnit] → IO PricesResponse 193 | tapToolsPrices env@(tteApiKey → apiKey) ttus = mkTapToolsClient apiKey & tapToolsPricesClient & (\f → f ttus) & runTapToolsClient env >>= handleTapToolsError "tapToolsPrices" 194 | -------------------------------------------------------------------------------- /geniusyield-server-lib/src/GeniusYield/Server/Dex/Markets.hs: -------------------------------------------------------------------------------- 1 | module GeniusYield.Server.Dex.Markets ( 2 | MarketsAPI, 3 | handleMarketsApi, 4 | ) where 5 | 6 | import Data.Aeson (camelTo2) 7 | import Data.Swagger qualified as Swagger 8 | import Deriving.Aeson 9 | import GHC.TypeLits (AppendSymbol) 10 | import GeniusYield.OrderBot.Domain.Markets (HasMarkets (getMarkets), OrderAssetPair (commodityAsset, currencyAsset)) 11 | import GeniusYield.Server.Ctx 12 | import GeniusYield.Server.Utils (CommonMaestroKeyRequirementText, addSwaggerDescription, logInfo) 13 | import GeniusYield.Types 14 | import RIO hiding (logDebug, logInfo) 15 | import Servant 16 | 17 | {- $setup 18 | 19 | >>> :set -XOverloadedStrings -XTypeApplications 20 | >>> import qualified Data.Aeson as Aeson 21 | >>> import qualified Data.ByteString.Lazy.Char8 as LBS8 22 | >>> import Data.Proxy 23 | >>> import qualified Data.Swagger as Swagger 24 | -} 25 | 26 | data Market = Market 27 | { marketId ∷ !OrderAssetPair, 28 | baseAsset ∷ !GYAssetClass, 29 | targetAsset ∷ !GYAssetClass 30 | } 31 | deriving stock (Show, Eq, Generic) 32 | deriving 33 | (FromJSON, ToJSON) 34 | via CustomJSON '[FieldLabelModifier '[CamelToSnake]] Market 35 | 36 | {- | 37 | >>> Aeson.encode (Swagger.toSchema (Proxy :: Proxy Market)) 38 | "{\"description\":\"Market information\",\"required\":[\"market_id\",\"base_asset\",\"target_asset\"],\"properties\":{\"market_id\":{\"$ref\":\"#/definitions/MarketId\"},\"base_asset\":{\"$ref\":\"#/definitions/BaseAsset\"},\"target_asset\":{\"$ref\":\"#/definitions/TargetAsset\"}},\"type\":\"object\"}" 39 | -} 40 | instance Swagger.ToSchema Market where 41 | declareNamedSchema = do 42 | Swagger.genericDeclareNamedSchema Swagger.defaultSchemaOptions {Swagger.fieldLabelModifier = camelTo2 '_'} 43 | & addSwaggerDescription "Market information" 44 | 45 | type MarketsAPI = 46 | Summary "Get markets information for the DEX." 47 | :> Description ("Returns the list of markets information supported by GeniusYield DEX. " `AppendSymbol` CommonMaestroKeyRequirementText) 48 | :> Get '[JSON] [Market] 49 | 50 | handleMarketsApi ∷ Ctx → ServerT MarketsAPI IO 51 | handleMarketsApi = handleMarkets 52 | 53 | handleMarkets ∷ Ctx → IO [Market] 54 | handleMarkets ctx = do 55 | logInfo ctx "Fetching markets." 56 | fmap fromOrderAssetPair <$> getMarkets (ctxMaestroProvider ctx) 57 | where 58 | fromOrderAssetPair ∷ OrderAssetPair → Market 59 | fromOrderAssetPair oap = Market {marketId = oap, baseAsset = currencyAsset oap, targetAsset = commodityAsset oap} 60 | -------------------------------------------------------------------------------- /geniusyield-server-lib/src/GeniusYield/Server/Options.hs: -------------------------------------------------------------------------------- 1 | module GeniusYield.Server.Options ( 2 | Command (..), 3 | ServeCommand (..), 4 | parseCommand, 5 | parseServeCommand, 6 | runCommand, 7 | runServeCommand, 8 | ) where 9 | 10 | import GeniusYield.Server.Run (runServer) 11 | import Options.Applicative 12 | import RIO 13 | 14 | newtype Command = Serve ServeCommand 15 | 16 | newtype ServeCommand = ServeCommand (Maybe FilePath) 17 | 18 | parseCommand ∷ Parser Command 19 | parseCommand = 20 | subparser 21 | $ mconcat 22 | [ command 23 | "serve" 24 | ( info (Serve <$> parseServeCommand <**> helper) 25 | $ progDesc "Serve endpoints" 26 | ) 27 | ] 28 | 29 | parseServeCommand ∷ Parser ServeCommand 30 | parseServeCommand = 31 | ServeCommand 32 | <$> optional 33 | ( strOption 34 | ( long "config" 35 | <> metavar "CONFIG" 36 | <> short 'c' 37 | <> help "Path of optional configuration file. If not provided, \"SERVER_CONFIG\" environment variable is used." 38 | ) 39 | ) 40 | 41 | runCommand ∷ Command → IO () 42 | runCommand (Serve serveCommand) = runServeCommand serveCommand 43 | 44 | runServeCommand ∷ ServeCommand → IO () 45 | runServeCommand (ServeCommand mcfp) = runServer mcfp 46 | -------------------------------------------------------------------------------- /geniusyield-server-lib/src/GeniusYield/Server/Orphans.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | module GeniusYield.Server.Orphans () where 4 | 5 | import Control.Lens (at, (?~)) 6 | import Data.HashMap.Strict.InsOrd qualified as IOHM 7 | import Data.OpenApi 8 | import Data.Swagger qualified as Swagger 9 | import Data.Swagger.Internal.Schema qualified as Swagger 10 | import GeniusYield.Server.Auth (APIKeyAuthProtect, apiKeyHeaderText) 11 | import RIO 12 | import Servant 13 | import Servant.Foreign 14 | import Servant.OpenApi 15 | 16 | instance Swagger.ToSchema Rational where 17 | declareNamedSchema _ = do 18 | integerSchema ← Swagger.declareSchemaRef @Integer Proxy 19 | return 20 | $ Swagger.named "Rational" 21 | $ mempty 22 | & Swagger.type_ 23 | ?~ Swagger.SwaggerObject 24 | & Swagger.properties 25 | .~ IOHM.fromList 26 | [ ("numerator", integerSchema), 27 | ("denominator", integerSchema) 28 | ] 29 | & Swagger.required 30 | .~ ["numerator", "denominator"] 31 | 32 | instance HasOpenApi api ⇒ HasOpenApi (APIKeyAuthProtect :> api) where 33 | toOpenApi _ = 34 | toOpenApi (Proxy ∷ Proxy api) 35 | & (components . securitySchemes) 36 | .~ SecurityDefinitions (IOHM.fromList [(apiKeyHeaderText, apiKeySecurityScheme)]) 37 | & allOperations 38 | . security 39 | .~ [SecurityRequirement (IOHM.singleton apiKeyHeaderText [])] 40 | & allOperations 41 | . responses 42 | %~ addCommonResponses 43 | where 44 | apiKeySecurityScheme ∷ SecurityScheme 45 | apiKeySecurityScheme = 46 | SecurityScheme 47 | { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams apiKeyHeaderText ApiKeyHeader), 48 | _securitySchemeDescription = Just "API key for accessing the server's API." 49 | } 50 | addCommonResponses ∷ Responses → Responses 51 | addCommonResponses resps = resps & at 401 ?~ Inline response401 & at 403 ?~ Inline response403 & at 500 ?~ Inline response500 52 | 53 | response401 ∷ Response 54 | response401 = mempty & description .~ "Unauthorized access - API key missing" 55 | 56 | response403 ∷ Response 57 | response403 = mempty & description .~ "Forbidden - The API key does not have permission to perform the request" 58 | 59 | response500 ∷ Response 60 | response500 = mempty & description .~ "Internal server error" 61 | 62 | -- `HasForeign` instance for `APIKeyAuthProtect :> api` is required to generate client code using libraries such as `servant-py`. 63 | -- This is written with help from https://github.com/haskell-servant/servant-auth/issues/8#issue-185541839. 64 | instance ∀ lang ftype api. (HasForeign lang ftype api, HasForeignType lang ftype Text) ⇒ HasForeign lang ftype (APIKeyAuthProtect :> api) where 65 | type Foreign ftype (APIKeyAuthProtect :> api) = Foreign ftype api 66 | foreignFor lang Proxy Proxy subR = foreignFor lang Proxy (Proxy ∷ Proxy api) subR' 67 | where 68 | subR' = subR {_reqHeaders = HeaderArg arg : _reqHeaders subR} 69 | arg = 70 | Arg 71 | { _argName = "api-key", 72 | _argType = typeFor lang (Proxy ∷ Proxy ftype) (Proxy ∷ Proxy Text) 73 | } 74 | -------------------------------------------------------------------------------- /geniusyield-server-lib/src/GeniusYield/Server/RequestLoggerMiddleware.hs: -------------------------------------------------------------------------------- 1 | module GeniusYield.Server.RequestLoggerMiddleware (gcpReqLogger) where 2 | 3 | import Data.Aeson ((.=)) 4 | import Data.Aeson qualified as Aeson 5 | import Data.Binary.Builder (toLazyByteString) 6 | import GeniusYield.Imports (lazyDecodeUtf8Lenient) 7 | import GeniusYield.Server.Utils (bytestringToString) 8 | import Network.HTTP.Types (statusCode) 9 | import Network.Wai 10 | import Network.Wai.Middleware.RequestLogger 11 | import RIO 12 | import RIO.ByteString qualified as BS 13 | import RIO.Text qualified as Txt 14 | import RIO.Time (UTCTime, defaultTimeLocale, parseTimeOrError) 15 | import System.Log.FastLogger 16 | 17 | -- See https://cloud.google.com/logging/docs/structured-logging. This Haskell code defines a middleware for logging HTTP requests in a Google Cloud Platform (GCP) compatible format. 18 | gcpReqLogger ∷ IO Middleware 19 | gcpReqLogger = 20 | mkRequestLogger 21 | defaultRequestLoggerSettings 22 | { outputFormat = CustomOutputFormatWithDetails formatter, 23 | destination = Handle stderr 24 | } 25 | where 26 | formatter ∷ OutputFormatterWithDetails 27 | formatter zonedDate req stat _ latency reqBodyChunks resp = 28 | let statCode = statusCode stat 29 | method = requestMethod req 30 | rawLog = 31 | toLogStr 32 | . Aeson.encode 33 | $ Aeson.object 34 | [ "severity" .= Txt.pack (if statCode >= 500 then "ERROR" else "INFO"), 35 | -- Only log response body for user-error and server-error responses. 36 | "message" .= if statCode >= 400 then lazyDecodeUtf8Lenient $ toLazyByteString resp else "", 37 | "time" .= zonedDateToSensibleTime zonedDate, 38 | "httpRequest" 39 | .= Aeson.object 40 | [ "requestMethod" .= bytestringToString method, 41 | "requestUrl" .= decodeUtf8Lenient ("https://self" <> rawPathInfo req <> rawQueryString req), 42 | "status" .= statCode, 43 | "latency" .= show latency, 44 | "reqBody" .= decodeUtf8Lenient (BS.concat reqBodyChunks) 45 | ] 46 | ] 47 | in rawLog <> "\n" -- Manually adding new line as there doesn't seem to be one in the GCP logs when being monitored through google cloud. 48 | 49 | -- Why does wai use ZonedDate from fast-logger + unix-time? 50 | zonedDateToSensibleTime ∷ ByteString → UTCTime 51 | zonedDateToSensibleTime = parseTimeOrError False defaultTimeLocale (bytestringToString simpleTimeFormat) . bytestringToString 52 | -------------------------------------------------------------------------------- /geniusyield-server-lib/src/GeniusYield/Server/Run.hs: -------------------------------------------------------------------------------- 1 | module GeniusYield.Server.Run ( 2 | runServer, 3 | ) where 4 | 5 | import Control.Monad.Trans.Except (ExceptT (ExceptT)) 6 | -- import Data.Aeson.Encode.Pretty (encodePretty) 7 | import Data.Strict qualified as Strict 8 | import Data.Version (showVersion) 9 | import Data.Yaml.Pretty qualified as Yaml 10 | import Fmt 11 | import GeniusYield.GYConfig 12 | import GeniusYield.HTTP.Errors 13 | import GeniusYield.Imports 14 | import GeniusYield.OrderBot.Adapter.Maestro (MaestroProvider (MaestroProvider)) 15 | import GeniusYield.Providers (networkIdToMaestroEnv) 16 | import GeniusYield.Server.Api 17 | import GeniusYield.Server.Auth 18 | import GeniusYield.Server.Config (ServerConfig (..), coreConfigFromServerConfig, optionalSigningKeyFromServerConfig, serverConfigOptionalFPIO) 19 | import GeniusYield.Server.Constants (gitHash) 20 | import GeniusYield.Server.Ctx 21 | -- import RIO.ByteString.Lazy qualified as BL 22 | 23 | -- import Servant.PY (requests, writePythonForAPI) 24 | 25 | import GeniusYield.Server.Dex.HistoricalPrices.TapTools.Client (tapToolsClientEnv) 26 | import GeniusYield.Server.ErrorMiddleware 27 | import GeniusYield.Server.RequestLoggerMiddleware (gcpReqLogger) 28 | import GeniusYield.Server.Utils 29 | import GeniusYield.Types 30 | import Network.Wai qualified as Wai 31 | import Network.Wai.Handler.Warp qualified as Warp 32 | import PackageInfo_geniusyield_server_lib qualified as PackageInfo 33 | import RIO hiding (Handler, logDebug, logErrorS, logInfo, logInfoS, onException) 34 | import RIO.ByteString qualified as B 35 | import RIO.Text.Lazy qualified as LT 36 | import Servant 37 | import Servant.Server.Experimental.Auth (AuthHandler) 38 | import Servant.Server.Internal.ServerError (responseServerError) 39 | import System.TimeManager (TimeoutThread (..)) 40 | 41 | runServer ∷ Maybe FilePath → IO () 42 | runServer mfp = do 43 | serverConfig ← serverConfigOptionalFPIO mfp 44 | menv ← networkIdToMaestroEnv (case scMaestroToken serverConfig of Confidential t → t) (scNetworkId serverConfig) 45 | mtenv ← 46 | case scTapToolsApiKey serverConfig of 47 | Nothing → pure Nothing 48 | Just (Confidential apiKey) → do 49 | tce ← tapToolsClientEnv 50 | pure $ Just $ TapToolsEnv {tteClientEnv = tce, tteApiKey = apiKey} 51 | optionalSigningKey ← optionalSigningKeyFromServerConfig serverConfig 52 | let nid = scNetworkId serverConfig 53 | coreCfg = coreConfigFromServerConfig serverConfig 54 | -- writePythonForAPI (Proxy @MainAPI) requests "web/swagger/api.py" 55 | withCfgProviders coreCfg "server" $ \providers → do 56 | let logInfoS = gyLogInfo providers mempty 57 | logErrorS = gyLogError providers mempty 58 | logInfoS $ "GeniusYield server version: " +| showVersion PackageInfo.version |+ "\nCommit used: " +| gitHash |+ "\nOptional collateral configuration: " +|| scCollateral serverConfig ||+ "\nAddress of optional wallet: " +|| fmap Strict.snd optionalSigningKey ||+ "\nOptional stake address: " +|| scStakeAddress serverConfig ||+ "" 59 | -- BL.writeFile "web/swagger/api.json" (encodePretty geniusYieldAPISwagger) 60 | B.writeFile "web/openapi/api.yaml" (Yaml.encodePretty Yaml.defConfig geniusYieldAPIOpenApi) 61 | reqLoggerMiddleware ← gcpReqLogger 62 | let 63 | -- These are only meant to catch fatal exceptions, application thrown exceptions should be caught beforehand. 64 | onException ∷ req → SomeException → IO () 65 | onException _req exc = 66 | displayException exc 67 | & if isMatchedException exceptionsToIgnore exc 68 | then logInfoS 69 | else logErrorS 70 | where 71 | -- TimeoutThread and Warp.ConnectionClosedByPeer do not indicate that anything is wrong and 72 | -- should not be logged as errors. See 73 | -- https://magnus.therning.org/2021-07-03-the-timeout-manager-exception.html 74 | -- https://www.rfc-editor.org/rfc/rfc5246#page-29 75 | exceptionsToIgnore = Proxy @TimeoutThread :>> Proxy @Warp.InvalidRequest :>> ENil 76 | onExceptionResponse ∷ SomeException → Wai.Response 77 | onExceptionResponse _ = responseServerError . apiErrorToServerError $ someBackendError "Internal Server Error" 78 | settings = 79 | Warp.defaultSettings 80 | & Warp.setPort (scPort serverConfig) 81 | & Warp.setOnException onException 82 | & Warp.setOnExceptionResponse onExceptionResponse 83 | errLoggerMiddleware = errorLoggerMiddleware $ logErrorS . LT.unpack 84 | ctx = 85 | Ctx 86 | { ctxProviders = providers, 87 | ctxNetworkId = nid, 88 | ctxDexInfo = 89 | if 90 | | nid == GYMainnet → dexInfoDefaultMainnet 91 | | nid == GYTestnetPreprod → dexInfoDefaultPreprod 92 | | otherwise → error "Only mainnet & preprod network are supported", 93 | ctxMaestroProvider = MaestroProvider menv, 94 | ctxTapToolsProvider = mtenv, 95 | ctxSigningKey = optionalSigningKey, 96 | ctxCollateral = scCollateral serverConfig, 97 | ctxStakeAddress = scStakeAddress serverConfig 98 | } 99 | 100 | logInfoS 101 | $ "Starting GeniusYield server on port " 102 | +| scPort serverConfig 103 | |+ "\nCore config:\n" 104 | +| indentF 4 (fromString $ show coreCfg) 105 | |+ "" 106 | Warp.runSettings settings 107 | . reqLoggerMiddleware 108 | . errLoggerMiddleware 109 | . errorJsonWrapMiddleware 110 | $ let context = apiKeyAuthHandler (case scServerApiKey serverConfig of Confidential t → apiKeyFromText t) :. EmptyContext 111 | in serveWithContext mainAPI context 112 | $ hoistServerWithContext 113 | mainAPI 114 | (Proxy ∷ Proxy '[AuthHandler Wai.Request ()]) 115 | (\ioAct → Handler . ExceptT $ first (apiErrorToServerError . exceptionHandler) <$> try ioAct) 116 | $ mainServer ctx 117 | -------------------------------------------------------------------------------- /geniusyield-server-lib/src/GeniusYield/Server/Tx.hs: -------------------------------------------------------------------------------- 1 | module GeniusYield.Server.Tx ( 2 | TxAPI, 3 | handleTxApi, 4 | handleTxSign, 5 | handleTxSignAndSubmit, 6 | handleTxSubmit, 7 | throwNoSigningKeyError, 8 | ) where 9 | 10 | import Data.Strict qualified as Strict 11 | import Fmt 12 | import GeniusYield.Server.Ctx 13 | import GeniusYield.Server.Utils 14 | import GeniusYield.Types 15 | import RIO hiding (logDebug, logInfo) 16 | import Servant 17 | 18 | type TxAPI = 19 | "sign" 20 | :> Summary "Sign a transaction" 21 | :> Description "Signs the given transaction using key configured in server." 22 | :> ReqBody '[JSON] GYTx 23 | :> Post '[JSON] GYTx 24 | :<|> "sign-and-submit" 25 | :> Summary "Sign and submit a transaction" 26 | :> Description "Signs the given transaction using key configured in server and submits it to the network." 27 | :> ReqBody '[JSON] GYTx 28 | :> Post '[JSON] GYTxId 29 | :<|> "submit" 30 | :> Summary "Submit a transaction" 31 | :> Description "Submits the given transaction to the network." 32 | :> ReqBody '[JSON] GYTx 33 | :> Post '[JSON] GYTxId 34 | 35 | handleTxApi ∷ Ctx → ServerT TxAPI IO 36 | handleTxApi ctx = 37 | handleTxSign ctx 38 | :<|> handleTxSignAndSubmit ctx 39 | :<|> handleTxSubmit ctx 40 | 41 | throwNoSigningKeyError ∷ IO a 42 | throwNoSigningKeyError = throwIO $ err500 {errBody = "No signing key configured."} 43 | 44 | handleTxSign ∷ Ctx → GYTx → IO GYTx 45 | handleTxSign ctx@Ctx {..} tx = do 46 | logInfo ctx $ "Signing transaction: " +| txToHex tx |+ "" 47 | case ctxSigningKey of 48 | Just sk → pure $ signGYTx' tx [somePaymentSigningKeyToSomeSigningKey $ Strict.fst sk] 49 | Nothing → throwNoSigningKeyError 50 | 51 | handleTxSignAndSubmit ∷ Ctx → GYTx → IO GYTxId 52 | handleTxSignAndSubmit ctx tx = do 53 | logInfo ctx $ "Signing and submitting transaction: " +| txToHex tx |+ "" 54 | signedTx ← handleTxSign ctx tx 55 | handleTxSubmit ctx signedTx 56 | 57 | handleTxSubmit ∷ Ctx → GYTx → IO GYTxId 58 | handleTxSubmit ctx@Ctx {..} tx = do 59 | logInfo ctx $ "Submitting transaction: " +| txToHex tx |+ "" 60 | gySubmitTx ctxProviders tx 61 | -------------------------------------------------------------------------------- /geniusyield-server-lib/src/GeniusYield/Server/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | 3 | module GeniusYield.Server.Utils ( 4 | ExceptionTypes (..), 5 | isMatchedException, 6 | logInfo, 7 | logDebug, 8 | dropSymbolAndCamelToSnake, 9 | addSwaggerDescription, 10 | addSwaggerExample, 11 | bytestringToString, 12 | hideServantClientErrorHeader, 13 | commonEnumParamSchemaRecipe, 14 | CommonMaestroKeyRequirementText, 15 | ) where 16 | 17 | import Control.Lens ((?~)) 18 | import Data.Swagger qualified as Swagger 19 | import Data.Swagger.Internal qualified as Swagger 20 | import GHC.TypeLits (Symbol) 21 | import GeniusYield.Imports 22 | import GeniusYield.Server.Ctx 23 | import GeniusYield.Swagger.Utils (addSwaggerDescription, addSwaggerExample, dropSymbolAndCamelToSnake) 24 | import GeniusYield.Types 25 | import Network.HTTP.Client qualified as Http 26 | import Network.HTTP.Types qualified as Http 27 | import RIO hiding (logDebug, logInfo) 28 | import RIO.Text qualified as Text 29 | import Servant.Client qualified as Servant 30 | import Servant.Client.Core qualified as Servant 31 | 32 | logDebug ∷ HasCallStack ⇒ Ctx → String → IO () 33 | logDebug ctx = gyLogDebug (ctxProviders ctx) mempty 34 | 35 | logInfo ∷ HasCallStack ⇒ Ctx → String → IO () 36 | logInfo ctx = gyLogInfo (ctxProviders ctx) mempty 37 | 38 | type ExceptionTypes ∷ [Type] → Type 39 | data ExceptionTypes es where 40 | ENil ∷ ExceptionTypes '[] 41 | (:>>) ∷ Exception e ⇒ Proxy e → ExceptionTypes es → ExceptionTypes (e ': es) 42 | 43 | infixr 5 :>> 44 | 45 | isMatchedException ∷ ExceptionTypes es → SomeException → Bool 46 | isMatchedException ENil _ = False 47 | isMatchedException (etype :>> etypes) se = isJust (f etype) || isMatchedException etypes se 48 | where 49 | f ∷ ∀ e. Exception e ⇒ Proxy e → Maybe e 50 | f _ = fromException @e se 51 | 52 | bytestringToString ∷ ByteString → String 53 | bytestringToString = RIO.decodeUtf8Lenient >>> Text.unpack 54 | 55 | hideServantClientErrorHeader ∷ Http.HeaderName → Servant.ClientError → Servant.ClientError 56 | hideServantClientErrorHeader headerName clientError = case clientError of 57 | Servant.FailureResponse reqF res → Servant.FailureResponse reqF {Servant.requestHeaders = renameHeader <$> Servant.requestHeaders reqF} res 58 | Servant.ConnectionError se → case fromException @Http.HttpException se of 59 | Just he → case he of 60 | Http.HttpExceptionRequest req content → Servant.ConnectionError $ SomeException $ Http.HttpExceptionRequest req {Http.requestHeaders = renameHeader <$> Http.requestHeaders req} content 61 | _anyOther → clientError 62 | Nothing → clientError 63 | _anyOther → clientError 64 | where 65 | renameHeader (h, v) = if h == headerName then (h, "hidden") else (h, v) 66 | 67 | commonEnumParamSchemaRecipe ∷ ∀ a (t ∷ Swagger.SwaggerKind Type). (Bounded a, Enum a, ToJSON a) ⇒ Proxy a → Swagger.ParamSchema t 68 | commonEnumParamSchemaRecipe _ = mempty & Swagger.type_ ?~ Swagger.SwaggerString & Swagger.enum_ ?~ fmap toJSON [(minBound ∷ a) .. maxBound] 69 | 70 | type CommonMaestroKeyRequirementText ∷ Symbol 71 | type CommonMaestroKeyRequirementText = "\"maestroToken\" field in the configuration is required for this operation." 72 | -------------------------------------------------------------------------------- /no-commit-to-main.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | if [ "${CI:=false}" == "true" ]; then 3 | echo "Running on CI. Nothing to check." 4 | exit 0; 5 | fi 6 | 7 | BRANCH=$(git branch --show-current) 8 | if [ "$BRANCH" == "main" ]; then 9 | echo "No commits allowed on $BRANCH branch!" 10 | exit 1; 11 | fi 12 | -------------------------------------------------------------------------------- /start.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | echo "======[geniusyield-server]======" 3 | echo "Startup checks...." 4 | # Check if SERVER_CONFIG environment variable is set 5 | if [ -z "$SERVER_CONFIG" ]; then 6 | echo "Error: SERVER_CONFIG environment variable is not set." >&2 7 | exit 1 # Exit code 1 for unset variable 8 | fi 9 | 10 | if [[ "$SERVER_CONFIG" == *"<>"* ]]; then 11 | if [ -z "$CORE_MAESTRO_API_KEY" ]; then 12 | echo "Error: CORE_MAESTRO_API_KEY environment variable is not set." >&2 13 | exit 1 # Exit code 1 for unset variable 14 | fi 15 | fi 16 | 17 | if [[ "$SERVER_CONFIG" == *"<>"* ]]; then 18 | if [ -z "$MAESTRO_API_KEY" ]; then 19 | echo "Error: MAESTRO_API_KEY environment variable is not set." >&2 20 | exit 1 # Exit code 1 for unset variable 21 | fi 22 | fi 23 | 24 | if [ -z "$SERVER_API_KEY" ]; then 25 | echo "Error: SERVER_API_KEY environment variable is not set." >&2 26 | exit 1 # Exit code 1 for unset variable 27 | fi 28 | 29 | if [ -z "$SEED_PHRASE" ]; then 30 | echo "Error: SEED_PHRASE environment variable is not set." >&2 31 | exit 1 # Exit code 1 for unset variable 32 | fi 33 | 34 | # Check if yq is installed 35 | if ! command -v yq &> /dev/null; then 36 | echo "Error: yq is not installed. Please install yq to validate YAML content." >&2 37 | exit 2 # Exit code 2 for yq not installed 38 | fi 39 | 40 | # Attempt to parse SERVER_CONFIG as YAML 41 | echo "$SERVER_CONFIG" | yq eval . - > /dev/null 2>&1 42 | if [ $? -ne 0 ]; then 43 | echo "Error: SERVER_CONFIG does not contain a valid YAML document." >&2 44 | exit 3 # Exit code 3 for invalid YAML content 45 | fi 46 | 47 | # If the script reaches this point, SERVER_CONFIG is both set and valid 48 | echo "SERVER_CONFIG is set and contains a valid YAML document." 49 | echo "====================================" 50 | echo "Replace placeholders...." 51 | echo "$SERVER_CONFIG" > ./server_config.yaml 52 | sed -i "s|<>|${CORE_MAESTRO_API_KEY}|" server_config.yaml 53 | sed -i "s|<>|${MAESTRO_API_KEY}|" server_config.yaml 54 | sed -i "s|<>|${SERVER_API_KEY}|" server_config.yaml 55 | sed -i "s|<>|${SEED_PHRASE}|" server_config.yaml 56 | export SERVER_CONFIG=$(cat server_config.yaml) 57 | echo "[OK] Done. Replaced placeholders." 58 | 59 | # Attempt to parse SERVER_CONFIG as YAML after replacing the placholde 60 | echo "$SERVER_CONFIG" | yq eval . - > /dev/null 2>&1 61 | if [ $? -ne 0 ]; then 62 | echo "Error: SERVER_CONFIG does not contain a valid YAML document after replacing the placeholders ." >&2 63 | exit 4 # Exit code 4 for invalid YAML content after replacing the placeholders 64 | fi 65 | echo "====================================" 66 | echo "Starting geniusyield-server..." 67 | set -x 68 | geniusyield-server serve 69 | --------------------------------------------------------------------------------