From eaa11afa70be75bbaa2123d87c0bc8b605d995df Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Mon, 29 Jan 2024 14:21:59 -0600 Subject: [PATCH 1/9] Update to latest version of `zcash-haskell` --- COPYING | 7 -- LICENSE | 191 +++++---------------------------------------------- package.yaml | 6 +- 3 files changed, 20 insertions(+), 184 deletions(-) delete mode 100644 COPYING diff --git a/COPYING b/COPYING deleted file mode 100644 index 2835367..0000000 --- a/COPYING +++ /dev/null @@ -1,7 +0,0 @@ -Copyright (c) 2022 Vergara Technologies LLC - -This package ("Original Work") is licensed under the terms of the Bootstrap -Open Source License, version 1.0, or at your option, any later version -("BOSL"). See the file ./LICENSE for the terms of the Bootstrap Open Source -Licence, version 1.0. - diff --git a/LICENSE b/LICENSE index 4eb1836..2f0193a 100644 --- a/LICENSE +++ b/LICENSE @@ -1,178 +1,21 @@ -Copyright (c) 2023 Vergara Technologies LLC +MIT License -======================================================= -Bootstrap Open Source Licence ("BOSL") v. 1.0 -======================================================= -This Bootstrap Open Source Licence (the "License") applies to any original work -of authorship (the "Original Work") whose owner (the "Licensor") has placed the -following licensing notice adjacent to the copyright notice for the Original -Work: +Copyright (c) 2022-2024 Vergara Technologies LLC -*Licensed under the Bootstrap Open Source Licence version 1.0* +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: -1. **Grant of Copyright License.** Licensor grants You a worldwide, - royalty-free, non-exclusive, sublicensable license, for the duration of the - copyright in the Original Work, to do the following: +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. - a. to reproduce the Original Work in copies, either alone or as part of - a collective work; - - b. to translate, adapt, alter, transform, modify, or arrange the - Original Work, thereby creating derivative works ("Derivative Works") - based upon the Original Work; - - c. to distribute or communicate copies of the Original Work and - Derivative Works to the public, provided that prior to any such - distribution or communication You first place a machine-readable copy - of the Source Code of the Original Work and such Derivative Works that - You intend to distribute or communicate in an information repository - reasonably calculated to permit inexpensive and convenient access - thereto by the public (“Information Repository”) for as long as You - continue to distribute or communicate said copies, accompanied by an - irrevocable offer to license said copies to the public free of charge - under this License, said offer valid starting no later than 12 months - after You first distribute or communicate said copies; - - d. to perform the Original Work publicly; and - - e. to display the Original Work publicly. - -2. **Grant of Patent License.** Licensor grants You a worldwide, royalty-free, -non-exclusive, sublicensable license, under patent claims owned or controlled -by the Licensor that are embodied in the Original Work as furnished by the -Licensor, for the duration of the patents, to make, use, sell, offer for sale, -have made, and import the Original Work and Derivative Works. - -3. **Grant of Source Code License.** The "Source Code" for a work means the -preferred form of the work for making modifications to it and all available -documentation describing how to modify the work. Licensor agrees to provide a -machine-readable copy of the Source Code of the Original Work along with each -copy of the Original Work that Licensor distributes. Licensor reserves the -right to satisfy this obligation by placing a machine-readable copy of said -Source Code in an Information Repository for as long as Licensor continues to -distribute the Original Work. - -4. **Exclusions From License Grant.** Neither the names of Licensor, nor the -names of any contributors to the Original Work, nor any of their trademarks or -service marks, may be used to endorse or promote products derived from this -Original Work without express prior permission of the Licensor. Except as -expressly stated herein, nothing in this License grants any license to -Licensor's trademarks, copyrights, patents, trade secrets or any other -intellectual property. No patent license is granted to make, use, sell, offer -for sale, have made, or import embodiments of any patent claims other than the -licensed claims defined in Section 2. No license is granted to the trademarks -of Licensor even if such marks are included in the Original Work. Nothing in -this License shall be interpreted to prohibit Licensor from licensing under -terms different from this License any Original Work that Licensor otherwise -would have a right to license. - -5. **External Deployment.** The term "External Deployment" means the use, -distribution, or communication of the Original Work or Derivative Works in any -way such that the Original Work or Derivative Works may be used by anyone other -than You, whether those works are distributed or communicated to those persons -or made available as an application intended for use over a network. As an -express condition for the grants of license hereunder, You must treat any -External Deployment by You of the Original Work or a Derivative Work as a -distribution under section 1(c). - -6. **Attribution Rights.** You must retain, in the Source Code of any -Derivative Works that You create, all copyright, patent, or trademark notices -from the Source Code of the Original Work, as well as any notices of licensing -and any descriptive text identified therein as an "Attribution Notice." You -must cause the Source Code for any Derivative Works that You create to carry a -prominent Attribution Notice reasonably calculated to inform recipients that -You have modified the Original Work. - -7. **Warranty of Provenance and Disclaimer of Warranty.** Licensor warrants -that the copyright in and to the Original Work and the patent rights granted -herein by Licensor are owned by the Licensor or are sublicensed to You under -the terms of this License with the permission of the contributor(s) of those -copyrights and patent rights. Except as expressly stated in the immediately -preceding sentence, the Original Work is provided under this License on an "AS -IS" BASIS and WITHOUT WARRANTY, either express or implied, including, without -limitation, the warranties of non-infringement, merchantability or fitness for -a particular purpose. THE ENTIRE RISK AS TO THE QUALITY OF THE ORIGINAL WORK IS -WITH YOU. This DISCLAIMER OF WARRANTY constitutes an essential part of this -License. No license to the Original Work is granted by this License except -under this disclaimer. - -8. **Limitation of Liability.** Under no circumstances and under no legal -theory, whether in tort (including negligence), contract, or otherwise, shall -the Licensor be liable to anyone for any indirect, special, incidental, or -consequential damages of any character arising as a result of this License or -the use of the Original Work including, without limitation, damages for loss of -goodwill, work stoppage, computer failure or malfunction, or any and all other -commercial damages or losses. This limitation of liability shall not apply to -the extent applicable law prohibits such limitation. - -9. **Acceptance and Termination.** If, at any time, You expressly assented to -this License, that assent indicates your clear and irrevocable acceptance of -this License and all of its terms and conditions. If You distribute or -communicate copies of the Original Work or a Derivative Work, You must make a -reasonable effort under the circumstances to obtain the express assent of -recipients to the terms of this License. This License conditions your rights to -undertake the activities listed in Section 1, including your right to create -Derivative Works based upon the Original Work, and doing so without honoring -these terms and conditions is prohibited by copyright law and international -treaty. Nothing in this License is intended to affect copyright exceptions and -limitations (including 'fair use' or 'fair dealing'). This License shall -terminate immediately and You may no longer exercise any of the rights granted -to You by this License upon your failure to honor the conditions in Section -1(c). - -10. **Termination for Patent Action.** This License shall terminate -automatically and You may no longer exercise any of the rights granted to You -by this License as of the date You commence an action, including a cross-claim -or counterclaim, against Licensor or any licensee alleging that the Original -Work infringes a patent. This termination provision shall not apply for an -action alleging patent infringement by combinations of the Original Work with -other software or hardware. - -11. **Jurisdiction, Venue and Governing Law.** Any action or suit relating to -this License may be brought only in the courts of a jurisdiction wherein the -Licensor resides or in which Licensor conducts its primary business, and under -the laws of that jurisdiction excluding its conflict-of-law provisions. The -application of the United Nations Convention on Contracts for the International -Sale of Goods is expressly excluded. Any use of the Original Work outside the -scope of this License or after its termination shall be subject to the -requirements and penalties of copyright or patent law in the appropriate -jurisdiction. This section shall survive the termination of this License. - -12. **Attorneys' Fees.** In any action to enforce the terms of this License or -seeking damages relating thereto, the prevailing party shall be entitled to -recover its costs and expenses, including, without limitation, reasonable -attorneys' fees and costs incurred in connection with such action, including -any appeal of such action. This section shall survive the termination of this -License. - -13. **Miscellaneous.** If any provision of this License is held to be -unenforceable, such provision shall be reformed only to the extent necessary to -make it enforceable. - -14. **Definition of "You" in This License.** "You" throughout this License, -whether in upper or lower case, means an individual or a legal entity -exercising rights under, and complying with all of the terms of, this License. -For legal entities, "You" includes any entity that controls, is controlled by, -or is under common control with you. For purposes of this definition, "control" -means (i) the power, direct or indirect, to cause the direction or management -of such entity, whether by contract or otherwise, or (ii) ownership of fifty -percent (50%) or more of the outstanding shares, or (iii) beneficial ownership -of such entity. - -15. **Right to Use.** You may use the Original Work in all ways not otherwise -restricted or conditioned by this License or by law, and Licensor promises not -to interfere with or be responsible for such uses by You. - -16. **Modification of This License.** This License is Copyright © 2007 Zooko -Wilcox-O'Hearn. Permission is granted to copy, distribute, or communicate this -License without modification. Nothing in this License permits You to modify -this License as applied to the Original Work or to Derivative Works. However, -You may modify the text of this License and copy, distribute or communicate -your modified version (the "Modified License") and apply it to other original -works of authorship subject to the following conditions: (i) You may not -indicate in any way that your Modified License is the "Bootstrap Open Source -Licence" or "BOSL" and you may not use those names in the name of your Modified -License; and (ii) You must replace the notice specified in the first paragraph -above with the notice "Licensed under " or with -a notice of your own that is not confusingly similar to the notice in this -License. +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/package.yaml b/package.yaml index 4f4d860..6f830c4 100644 --- a/package.yaml +++ b/package.yaml @@ -1,10 +1,10 @@ name: zgo-backend -version: 1.8.0 +version: 1.8.1 git: "https://git.vergara.tech/Vergara_Tech/zgo-backend" -license: BOSL +license: MIT author: "Rene Vergara" maintainer: "rene@vergara.network" -copyright: "Copyright (c) 2023 Vergara Technologies LLC" +copyright: "2022-2024 Vergara Technologies LLC" extra-source-files: - README.md -- 2.43.0 From ab6cc7f4135086e074cb2994e1330100a7a739a6 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Mon, 29 Jan 2024 14:22:51 -0600 Subject: [PATCH 2/9] Update version --- CHANGELOG.md | 8 ++++++++ src/ZGoBackend.hs | 9 ++++----- src/ZGoTx.hs | 6 +++--- stack.yaml | 8 +++++--- stack.yaml.lock | 22 +++++++++++----------- zgo-backend.cabal | 8 ++++---- 6 files changed, 35 insertions(+), 26 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index d87c1a2..30619dc 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,14 @@ All notable changes to this project will be documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## [1.8.1] + +### Changed + +- Changed license to MIT +- Updated to Haskell LTS 21.22 +- Update to new version of `zcash-haskell` + ## [1.8.0] ### Added diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index da23781..a5a0bac 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -15,7 +15,6 @@ import Control.Monad.IO.Class import Crypto.RNG (newCryptoRNGState, runCryptoRNGT) import Crypto.RNG.Utils (randomString) import Data.Aeson -import Data.Aeson (decodeFileStrict) import Data.Array import qualified Data.Bson as B import qualified Data.ByteArray as BA @@ -1254,9 +1253,9 @@ routes pipe config = do else case decodeUfvk (C.pack q) of Nothing -> status badRequest400 Just fvk -> do - if isValidUnifiedAddress $ - C.pack . T.unpack $ uaddress u' - then do + case isValidUnifiedAddress $ + C.pack . T.unpack $ uaddress u' of + Just uaok -> do if matchOrchardAddress (C.pack q) (C.pack . T.unpack $ uaddress u') @@ -1271,7 +1270,7 @@ routes pipe config = do run (upsertViewingKey o' q) status created201 else status forbidden403 - else do + Nothing -> do if matchSaplingAddress (s_key fvk) (bytes . decodeBech32 . C.pack . T.unpack $ diff --git a/src/ZGoTx.hs b/src/ZGoTx.hs index 3749eb4..f33d196 100644 --- a/src/ZGoTx.hs +++ b/src/ZGoTx.hs @@ -144,9 +144,9 @@ pUnifiedAddress :: Parser MemoToken pUnifiedAddress = do string "u1" a <- some alphaNumChar - if isValidUnifiedAddress (E.encodeUtf8 $ "u1" <> T.pack a) - then pure $ Address $ T.pack ("u1" <> a) - else fail "Failed to parse Unified Address" + case isValidUnifiedAddress (E.encodeUtf8 $ "u1" <> T.pack a) of + Just u -> pure $ Address $ T.pack ("u1" <> a) + Nothing -> fail "Failed to parse Unified Address" pOrderId :: Parser MemoToken pOrderId = do diff --git a/stack.yaml b/stack.yaml index 8f78da2..3cd01e4 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,7 +17,7 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-21.17 +resolver: lts-21.22 #url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/4.yaml # User packages to be built. @@ -42,10 +42,12 @@ packages: # # extra-deps: [] extra-deps: - - git: https://github.com/reach-sh/haskell-hexstring.git + #- git: https://github.com/reach-sh/haskell-hexstring.git + #commit: 085c16fb21b9f856a435a3faab980e7e0b319341 + - git: https://git.vergara.tech/Vergara_Tech/haskell-hexstring.git commit: 085c16fb21b9f856a435a3faab980e7e0b319341 - git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git - commit: 1d558fc646a7758d60a721124812070de222c2e1 + commit: dce171d83043fae0e5c771ff743d31c4ec19c1ae - git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05 - git: https://github.com/well-typed/borsh.git diff --git a/stack.yaml.lock b/stack.yaml.lock index d88e25b..015116c 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -6,7 +6,7 @@ packages: - completed: commit: 085c16fb21b9f856a435a3faab980e7e0b319341 - git: https://github.com/reach-sh/haskell-hexstring.git + git: https://git.vergara.tech/Vergara_Tech/haskell-hexstring.git name: hexstring pantry-tree: sha256: 9ecf67856f59dfb382b283eceb42e4fc1865935d1a7e59111556ed381c6a2ffd @@ -14,17 +14,17 @@ packages: version: 0.11.1 original: commit: 085c16fb21b9f856a435a3faab980e7e0b319341 - git: https://github.com/reach-sh/haskell-hexstring.git + git: https://git.vergara.tech/Vergara_Tech/haskell-hexstring.git - completed: - commit: 1d558fc646a7758d60a721124812070de222c2e1 + commit: dce171d83043fae0e5c771ff743d31c4ec19c1ae git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git name: zcash-haskell pantry-tree: - sha256: eab3c6817bb3cb5738725824d16eb023cb2967ef3bbaa8f8252524602f606dbb - size: 1229 - version: 0.2.0 + sha256: 000770930e5d50596b82b38984d6e8ab94fd5345c7fcf3cc21682ef8e6348746 + size: 1365 + version: 0.3.0 original: - commit: 1d558fc646a7758d60a721124812070de222c2e1 + commit: dce171d83043fae0e5c771ff743d31c4ec19c1ae git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git - completed: commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05 @@ -103,7 +103,7 @@ packages: hackage: crypto-rng-0.3.0.1@sha256:04f4ae75943ecad8b794950985054130f272d65a588b6b6528f56df0bfedc4dc,1565 snapshots: - completed: - sha256: 85d2382958c178491d3fe50d770a624621f5ab456beef7d31ac7521f780c9bc7 - size: 640042 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/17.yaml - original: lts-21.17 + sha256: afd5ba64ab602cabc2d3942d3d7e7dd6311bc626dcb415b901eaf576cb62f0ea + size: 640060 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/22.yaml + original: lts-21.22 diff --git a/zgo-backend.cabal b/zgo-backend.cabal index 0d59748..dc289d8 100644 --- a/zgo-backend.cabal +++ b/zgo-backend.cabal @@ -1,18 +1,18 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: zgo-backend -version: 1.8.0 +version: 1.8.1 synopsis: Haskell Back-end for the ZGo point-of-sale application description: Please see the README at category: Web author: Rene Vergara maintainer: rene@vergara.network -copyright: Copyright (c) 2023 Vergara Technologies LLC -license: BOSL +copyright: 2022-2024 Vergara Technologies LLC +license: MIT license-file: LICENSE build-type: Simple extra-source-files: -- 2.43.0 From c3903f4979dd58197d8f878b6fd3a43d11a0d535 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Mon, 20 May 2024 08:39:13 -0500 Subject: [PATCH 3/9] Replace stack with cabal --- cabal.project | 20 ++++++ package.yaml | 167 ------------------------------------------------ stack.yaml | 86 ------------------------- stack.yaml.lock | 109 ------------------------------- 4 files changed, 20 insertions(+), 362 deletions(-) create mode 100644 cabal.project delete mode 100644 package.yaml delete mode 100644 stack.yaml delete mode 100644 stack.yaml.lock diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..5429a99 --- /dev/null +++ b/cabal.project @@ -0,0 +1,20 @@ +packages: + ./*.cabal + zcash-haskell/zcash-haskell.cabal + +with-compiler: ghc-9.6.5 + +source-repository-package + type: git + location: https://git.vergara.tech/Vergara_Tech/haskell-hexstring.git + tag: 39d8da7b11a80269454c2f134a5c834e0f3cb9a7 + +source-repository-package + type: git + location: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git + tag: 335e804454cd30da2c526457be37e477f71e4665 + +source-repository-package + type: git + location: https://github.com/khazaddum/borsh.git + tag: 5f49e963b0a6f784623c7d11ec500f3e3566dcfe diff --git a/package.yaml b/package.yaml deleted file mode 100644 index 6f830c4..0000000 --- a/package.yaml +++ /dev/null @@ -1,167 +0,0 @@ -name: zgo-backend -version: 1.8.1 -git: "https://git.vergara.tech/Vergara_Tech/zgo-backend" -license: MIT -author: "Rene Vergara" -maintainer: "rene@vergara.network" -copyright: "2022-2024 Vergara Technologies LLC" - -extra-source-files: -- README.md -- CHANGELOG.md -- zgo.cfg - -# Metadata used when publishing your package -synopsis: Haskell Back-end for the ZGo point-of-sale application -category: Web - -# To avoid duplicated efforts in documentation and dealing with the -# complications of embedding Haddock markup inside cabal files, it is -# common to point users to the README.md file. -description: Please see the README at - -dependencies: -- base >= 4.7 && < 5 - -library: - source-dirs: src - dependencies: - - mongoDB - - time - - text - - unordered-containers - - bson - - aeson - - QuickCheck - - quickcheck-instances - - scotty - - http-conduit - - wai-extra - - http-types - - time - - securemem - - bytestring - - regex-base - - regex-compat - - array - - random - - vector - - wai-cors - - warp-tls - - hexstring - - configurator - - scientific - - jwt - - containers - - base64-bytestring - - wai - - blake3 - - memory - - ghc-prim - - network - - crypto-rng - - megaparsec - - uuid - - zcash-haskell - -executables: - zgo-backend-exe: - main: Server.hs - source-dirs: app - ghc-options: - - -main-is Server - - -threaded - - -rtsopts - - -with-rtsopts=-N - - -Wall - dependencies: - - zgo-backend - - base - - scotty - - wai-extra - - securemem - - text - - aeson - - mongoDB - - http-types - - http-conduit - - time - - bytestring - - configurator - - warp-tls - - warp - - megaparsec - zgo-token-refresh: - main: TokenRefresh.hs - source-dirs: app - ghc-options: - - -main-is TokenRefresh - - -threaded - - -rtsopts - - -with-rtsopts=-N - - -Wall - dependencies: - - base - - zgo-backend - - base - - scotty - - wai-extra - - securemem - - text - - aeson - - mongoDB - - http-types - - http-conduit - - time - - bytestring - - configurator - - warp-tls - - warp - - megaparsec - zgo-tasks: - main: Tasks.hs - source-dirs: app - ghc-options: - - -main-is Tasks - - -threaded - - -rtsopts - - -with-rtsopts=-N - - -Wall - dependencies: - - base - - mongoDB - - zgo-backend - - scotty - - warp-tls - - warp - - time - - megaparsec - -tests: - zgo-backend-test: - main: Spec.hs - source-dirs: test - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - - -main-is Spec - dependencies: - - zgo-backend - - hspec - - QuickCheck - - text - - aeson - - http-conduit - - http-types - - hspec-expectations-json - - bytestring - - mongoDB - - hspec-wai - - securemem - - time - - configurator - - scotty - - megaparsec - - uuid - - zcash-haskell diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 index 3cd01e4..0000000 --- a/stack.yaml +++ /dev/null @@ -1,86 +0,0 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# -# The location of a snapshot can be provided as a file or url. Stack assumes -# a snapshot provided as a file might change, whereas a url resource does not. -# -# resolver: ./custom-snapshot.yaml -# resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-21.22 - #url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/4.yaml - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# subdirs: -# - auto-update -# - wai -packages: -- . -# Dependency packages to be pulled from upstream that are not in the resolver. -# These entries can reference officially published versions as well as -# forks / in-progress versions pinned to a git hash. For example: -# -# extra-deps: -# - acme-missiles-0.3 -# - git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# -# extra-deps: [] -extra-deps: - #- git: https://github.com/reach-sh/haskell-hexstring.git - #commit: 085c16fb21b9f856a435a3faab980e7e0b319341 - - git: https://git.vergara.tech/Vergara_Tech/haskell-hexstring.git - commit: 085c16fb21b9f856a435a3faab980e7e0b319341 - - git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git - commit: dce171d83043fae0e5c771ff743d31c4ec19c1ae - - git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git - commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05 - - git: https://github.com/well-typed/borsh.git - commit: d2fcfa159e0a844b1ec5e8ed3e232d4b380fa831 - - git: https://git.vergara.tech/Vergara_Tech/mongodb.git - commit: 63bba3a6d30e5fd73c71fd7da752b2647d94f58e - # - network-2.8.0.1@sha256:a79f3cf88b2623d5f2e7a8fc7962055f6858d6beb6d13c2aef43c20a5060cf28,3034 - - aeson-2.1.2.1@sha256:5b8d62a60963a925c4d123a46e42a8e235a32188522c9f119f64ac228c2612a7,6359 - - vector-0.13.0.0@sha256:fa5cac81a17a5af388716792e8b99c24b3b66770086756d0d8b23f8272a0244c,9112 - - generically-0.1.1 - - vector-algorithms-0.9.0.1 - - blake3-0.2@sha256:d1146b9a51ccfbb0532780778b6d016a614e3d44c05d8c1923dde9a8be869045,2448 - - crypto-rng-0.3.0.1@sha256:04f4ae75943ecad8b794950985054130f272d65a588b6b6528f56df0bfedc4dc,1565 -# Override default flag values for local packages and extra-deps -# flags: {} - -# Extra package databases containing global packages -# extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=2.7" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor diff --git a/stack.yaml.lock b/stack.yaml.lock deleted file mode 100644 index 015116c..0000000 --- a/stack.yaml.lock +++ /dev/null @@ -1,109 +0,0 @@ -# This file was autogenerated by Stack. -# You should not edit this file by hand. -# For more information, please see the documentation at: -# https://docs.haskellstack.org/en/stable/lock_files - -packages: -- completed: - commit: 085c16fb21b9f856a435a3faab980e7e0b319341 - git: https://git.vergara.tech/Vergara_Tech/haskell-hexstring.git - name: hexstring - pantry-tree: - sha256: 9ecf67856f59dfb382b283eceb42e4fc1865935d1a7e59111556ed381c6a2ffd - size: 687 - version: 0.11.1 - original: - commit: 085c16fb21b9f856a435a3faab980e7e0b319341 - git: https://git.vergara.tech/Vergara_Tech/haskell-hexstring.git -- completed: - commit: dce171d83043fae0e5c771ff743d31c4ec19c1ae - git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git - name: zcash-haskell - pantry-tree: - sha256: 000770930e5d50596b82b38984d6e8ab94fd5345c7fcf3cc21682ef8e6348746 - size: 1365 - version: 0.3.0 - original: - commit: dce171d83043fae0e5c771ff743d31c4ec19c1ae - git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git -- completed: - commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05 - git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git - name: foreign-rust - pantry-tree: - sha256: be2f6fc0fab58a90fec657bdb6bd0ccf0810c7dccfe95c78b85e174fae227e42 - size: 2315 - version: 0.1.0 - original: - commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05 - git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git -- completed: - commit: d2fcfa159e0a844b1ec5e8ed3e232d4b380fa831 - git: https://github.com/well-typed/borsh.git - name: borsh - pantry-tree: - sha256: 8335925f495a5a653fcb74b6b8bb18cd0b6b7fe7099a1686108704e6ab82f47b - size: 2268 - version: 0.3.0 - original: - commit: d2fcfa159e0a844b1ec5e8ed3e232d4b380fa831 - git: https://github.com/well-typed/borsh.git -- completed: - commit: 63bba3a6d30e5fd73c71fd7da752b2647d94f58e - git: https://git.vergara.tech/Vergara_Tech/mongodb.git - name: mongoDB - pantry-tree: - sha256: 63af9dc2612131fb5d1ea9d75b7055d5d0b28ca443149be1fb47c22bf204128f - size: 2297 - version: 2.7.1.2 - original: - commit: 63bba3a6d30e5fd73c71fd7da752b2647d94f58e - git: https://git.vergara.tech/Vergara_Tech/mongodb.git -- completed: - hackage: aeson-2.1.2.1@sha256:5b8d62a60963a925c4d123a46e42a8e235a32188522c9f119f64ac228c2612a7,6359 - pantry-tree: - sha256: 58d33beedd6e0ff79920c636d8a4295deb684b6e97c9b1ca94d3c780958d6302 - size: 82465 - original: - hackage: aeson-2.1.2.1@sha256:5b8d62a60963a925c4d123a46e42a8e235a32188522c9f119f64ac228c2612a7,6359 -- completed: - hackage: vector-0.13.0.0@sha256:fa5cac81a17a5af388716792e8b99c24b3b66770086756d0d8b23f8272a0244c,9112 - pantry-tree: - sha256: d2461d28022c8c0a91da08b579b1bff478f617102d2f5ef596cc5b28d14b8b6a - size: 4092 - original: - hackage: vector-0.13.0.0@sha256:fa5cac81a17a5af388716792e8b99c24b3b66770086756d0d8b23f8272a0244c,9112 -- completed: - hackage: generically-0.1.1@sha256:2b9b5efb6eea2fb65377565d53d85b0ccc5b37404fba4bef1d60277caa877e5e,1155 - pantry-tree: - sha256: 98a8fe89d516d3752a9cc0af22cfa652f098cc6613da080762b63aa1d596e56d - size: 233 - original: - hackage: generically-0.1.1 -- completed: - hackage: vector-algorithms-0.9.0.1@sha256:f3e5c6695529a94edf762117cafd91c989cb642ad3f8ca4014dbb13c8f6c2a20,3826 - pantry-tree: - sha256: aef389e57ae6020e5da719bee40aaf6cccf1c4d1e7743a85d30c9d8c25d170a0 - size: 1510 - original: - hackage: vector-algorithms-0.9.0.1 -- completed: - hackage: blake3-0.2@sha256:d1146b9a51ccfbb0532780778b6d016a614e3d44c05d8c1923dde9a8be869045,2448 - pantry-tree: - sha256: 0264ef3e7919e7b0d668c4153f6ce0d88e6965626b52d9dfd2cafd70309501d3 - size: 1433 - original: - hackage: blake3-0.2@sha256:d1146b9a51ccfbb0532780778b6d016a614e3d44c05d8c1923dde9a8be869045,2448 -- completed: - hackage: crypto-rng-0.3.0.1@sha256:04f4ae75943ecad8b794950985054130f272d65a588b6b6528f56df0bfedc4dc,1565 - pantry-tree: - sha256: 1caccafe35d1ae3063f057c31188742a8e794f4f4e4530bab4019c0a514ee54f - size: 455 - original: - hackage: crypto-rng-0.3.0.1@sha256:04f4ae75943ecad8b794950985054130f272d65a588b6b6528f56df0bfedc4dc,1565 -snapshots: -- completed: - sha256: afd5ba64ab602cabc2d3942d3d7e7dd6311bc626dcb415b901eaf576cb62f0ea - size: 640060 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/22.yaml - original: lts-21.22 -- 2.43.0 From a28caf0fbab890331bfa98561c54a649793b7724 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Mon, 20 May 2024 08:39:31 -0500 Subject: [PATCH 4/9] Add `zcash-haskell` as submodule --- .gitmodules | 4 ++++ zcash-haskell | 1 + 2 files changed, 5 insertions(+) create mode 100644 .gitmodules create mode 160000 zcash-haskell diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..b77a9e5 --- /dev/null +++ b/.gitmodules @@ -0,0 +1,4 @@ +[submodule "zcash-haskell"] + path = zcash-haskell + url = https://git.vergara.tech/Vergara_Tech/zcash-haskell + branch = milestone2 diff --git a/zcash-haskell b/zcash-haskell new file mode 160000 index 0000000..90c8a7c --- /dev/null +++ b/zcash-haskell @@ -0,0 +1 @@ +Subproject commit 90c8a7c3028bd6836dea5655221277a25d457653 -- 2.43.0 From db0787ac326bb77955b7e6d34055d7591caec9b6 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Mon, 20 May 2024 08:39:52 -0500 Subject: [PATCH 5/9] Code refactor for update libraries --- src/ZGoBackend.hs | 376 +++++++++++++++++++++++----------------------- zgo-backend.cabal | 34 ++--- 2 files changed, 197 insertions(+), 213 deletions(-) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index a5a0bac..29f62ef 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -62,7 +62,7 @@ import Text.Megaparsec (runParser) import Text.Regex import Text.Regex.Base import User -import Web.Scotty +import Web.Scotty hiding (getResponseStatus) import WooCommerce import Xero import ZGoTx @@ -91,8 +91,8 @@ instance (FromJSON r) => FromJSON (Payload r) where -- | Type to model a (simplified) block of Zcash blockchain data Block = Block - { height :: Integer - , size :: Integer + { height :: !Integer + , size :: !Integer } deriving (Show, Generic, ToJSON) instance FromJSON Block where @@ -101,14 +101,14 @@ instance FromJSON Block where -- | Type to model a Zcash shielded transaction data ZcashTx = ZcashTx - { ztxid :: T.Text - , zamount :: Double - , zamountZat :: Integer - , zblockheight :: Integer - , zblocktime :: Integer - , zchange :: Bool - , zconfirmations :: Integer - , zmemo :: T.Text + { ztxid :: !HexString + , zamount :: !Double + , zamountZat :: !Integer + , zblockheight :: !Integer + , zblocktime :: !Integer + , zchange :: !Bool + , zconfirmations :: !Integer + , zmemo :: !T.Text } deriving (Show, Generic) instance FromJSON ZcashTx where @@ -155,14 +155,14 @@ instance Arbitrary ZcashTx where bt <- arbitrary c <- arbitrary cm <- arbitrary - ZcashTx a aZ t bh bt c cm <$> arbitrary + ZcashTx (HexString a) aZ t bh bt c cm <$> arbitrary -- | A type to model an address group data AddressGroup = AddressGroup - { agsource :: AddressSource - , agtransparent :: [ZcashAddress] - , agsapling :: [ZcashAddress] - , agunified :: [ZcashAddress] + { agsource :: !AddressSource + , agtransparent :: ![ZcashAddress] + , agsapling :: ![ZcashAddress] + , agunified :: ![ZcashAddress] } deriving (Show, Generic) instance FromJSON AddressGroup where @@ -245,10 +245,10 @@ instance FromJSON ZcashPool where _ -> fail "Not a known Zcash pool" data ZcashAddress = ZcashAddress - { source :: AddressSource - , pool :: [ZcashPool] - , account :: Maybe Integer - , addy :: T.Text + { source :: !AddressSource + , pool :: ![ZcashPool] + , account :: !(Maybe Integer) + , addy :: !T.Text } deriving (Eq) instance Show ZcashAddress where @@ -269,14 +269,14 @@ decodeHexText h = E.decodeUtf8With lenientDecode $ BS.pack $ hexRead h -- | Helper function to turn a string into a hex-encoded string encodeHexText :: T.Text -> String -encodeHexText t = T.unpack . toText . fromBytes $ E.encodeUtf8 t +encodeHexText t = T.unpack . toText . fromRawBytes $ E.encodeUtf8 t -- Types for the ZGo database documents -- | Type to model a country for the database's country list data Country = Country - { _id :: String - , name :: T.Text - , code :: T.Text + { _id :: !String + , name :: !T.Text + , code :: !T.Text } deriving (Eq, Show, Generic, ToJSON) parseCountryBson :: B.Document -> Maybe Country @@ -304,24 +304,24 @@ zToZGoTx (ZcashTx t a aZ bh bt c conf m) = do then do let sess = T.pack (fst $ head reg ! 1) let nAddy = T.pack (fst $ head reg ! 2) - ZGoTx Nothing nAddy sess conf bt a t m + ZGoTx Nothing nAddy sess conf bt a (toText t) m else do if not (null reg2) then do let sess = T.pack (fst $ head reg2 ! 1) - ZGoTx Nothing "" sess conf bt a t m + ZGoTx Nothing "" sess conf bt a (toText t) m else do if not (null reg3) then do let sess = T.pack (fst $ head reg3 ! 2) let nAddy = T.pack (fst $ head reg3 ! 1) - ZGoTx Nothing nAddy sess conf bt a t m - else ZGoTx Nothing "" "" conf bt a t m + ZGoTx Nothing nAddy sess conf bt a (toText t) m + else ZGoTx Nothing "" "" conf bt a (toText t) m zToZGoTx' :: Config -> Pipe -> ZcashTx -> IO () zToZGoTx' config pipe (ZcashTx t a aZ bh bt c conf m) = do when (conf < c_confirmations config) $ do - let zM = runParser pZGoMemo (T.unpack t) m + let zM = runParser pZGoMemo (T.unpack . toText $ t) m case zM of Right zM' -> do print zM' @@ -333,7 +333,7 @@ zToZGoTx' config pipe (ZcashTx t a aZ bh bt c conf m) = do conf bt a - t + (toText t) m if m_payment zM' then upsertPayment pipe (c_dbName config) tx @@ -342,10 +342,10 @@ zToZGoTx' config pipe (ZcashTx t a aZ bh bt c conf m) = do -- |Type to model a price in the ZGo database data ZGoPrice = ZGoPrice - { _id :: String - , currency :: T.Text - , price :: Double - , timestamp :: UTCTime + { _id :: !String + , currency :: !T.Text + , price :: !Double + , timestamp :: !UTCTime } deriving (Eq, Show, Generic, ToJSON) parseZGoPrice :: B.Document -> Maybe ZGoPrice @@ -408,9 +408,9 @@ sendPin nodeUser nodePwd nodeAddress addr pin = do -- | Type for Operation Result data OpResult = OpResult - { opsuccess :: T.Text - , opmessage :: Maybe T.Text - , optxid :: Maybe T.Text + { opsuccess :: !T.Text + , opmessage :: !(Maybe T.Text) + , optxid :: !(Maybe T.Text) } deriving (Show, Eq) instance FromJSON OpResult where @@ -469,6 +469,7 @@ addUser nodeUser nodePwd p db node (Just tx) = do _ <- liftIO $ sendPin nodeUser nodePwd node (address tx) (T.pack newPin) let pinHash = BLK.hash + Nothing [ BA.pack . BS.unpack . C.pack . T.unpack $ T.pack newPin <> session tx :: BA.Bytes ] @@ -607,19 +608,18 @@ routes pipe config = do middleware $ zgoAuth pipe $ c_dbName config --Get list of countries for UI get "/api/countries" $ do - countries <- liftAndCatchIO $ run listCountries - case countries of - [] -> do - status noContent204 - _ -> do + countries <- liftIO $ run listCountries + if not (null countries) + then do Web.Scotty.json (object [ "message" .= ("Country data found" :: String) , "countries" .= toJSON (map parseCountryBson countries) ]) + else status noContent204 --Get Xero credentials get "/api/xero" $ do - xeroConfig <- liftAndCatchIO $ run findXero + xeroConfig <- liftIO $ run findXero case xeroConfig of Nothing -> status noContent204 Just x -> do @@ -634,10 +634,10 @@ routes pipe config = do , "xeroConfig" .= toJSON (c :: Xero) ]) get "/api/xerotoken" $ do - code <- param "code" - session <- param "session" - user <- liftAndCatchIO $ run (findUser session) - xeroConfig <- liftAndCatchIO $ run findXero + code <- formParam "code" + session <- formParam "session" + user <- liftIO $ run (findUser session) + xeroConfig <- liftIO $ run findXero case cast' . Doc =<< xeroConfig of Nothing -> status noContent204 Just c -> do @@ -645,14 +645,14 @@ routes pipe config = do Nothing -> status unauthorized401 Just u -> do res <- - liftAndCatchIO $ + liftIO $ requestXeroToken pipe (c_dbName config) c code $ uaddress u if res then status ok200 else status noContent204 post "/invdata" $ do invData <- jsonData - xeroConfig <- liftAndCatchIO $ run findXero + xeroConfig <- liftIO $ run findXero let invReq = payload (invData :: Payload XeroInvoiceRequest) case cast' . Doc =<< xeroConfig of Nothing -> do @@ -664,7 +664,7 @@ routes pipe config = do , "shop" .= (Nothing :: Maybe String) ]) Just c -> do - o <- liftAndCatchIO $ run $ findOwnerById $ xr_owner invReq + o <- liftIO $ run $ findOwnerById $ xr_owner invReq case cast' . Doc =<< o of Nothing -> do status ok200 @@ -676,7 +676,7 @@ routes pipe config = do ]) Just o' -> do existingOrder <- - liftAndCatchIO $ + liftIO $ run $ findXeroOrder (oaddress o') @@ -685,12 +685,12 @@ routes pipe config = do case cast' . Doc =<< existingOrder of Nothing -> do res <- - liftAndCatchIO $ + liftIO $ requestXeroToken pipe (c_dbName config) c "none" $ oaddress o' if res then do resInv <- - liftAndCatchIO $ + liftIO $ getXeroInvoice pipe (c_dbName config) (xr_invNo invReq) $ oaddress o' case resInv of @@ -712,7 +712,7 @@ routes pipe config = do now <- liftIO getCurrentTime tk <- liftIO generateToken pr <- - liftAndCatchIO $ + liftIO $ run (findPrice $ T.unpack . ocurrency $ o') @@ -765,11 +765,11 @@ routes pipe config = do 0 0 _ <- - liftAndCatchIO $ + liftIO $ run $ upsertOrder newOrder 0 0 finalOrder <- - liftAndCatchIO $ + liftIO $ run $ findXeroOrder (oaddress o') @@ -850,12 +850,12 @@ routes pipe config = do ]) -- Get the xeroaccount code get "/api/xeroaccount" $ do - session <- param "session" - user <- liftAndCatchIO $ run (findUser session) + session <- formParam "session" + user <- liftIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status unauthorized401 Just u -> do - res <- liftAndCatchIO $ run (findToken $ uaddress u) + res <- liftIO $ run (findToken $ uaddress u) let c = cast' . Doc =<< res case c of Nothing -> status noContent204 @@ -868,27 +868,27 @@ routes pipe config = do ]) -- Save the xeroaccount code post "/api/xeroaccount" $ do - session <- param "session" - c <- param "code" - user <- liftAndCatchIO $ run (findUser session) + session <- formParam "session" + c <- formParam "code" + user <- liftIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status unauthorized401 Just u -> do let oAdd = uaddress u - liftAndCatchIO $ run (addAccCode oAdd c) + liftIO $ run (addAccCode oAdd c) status accepted202 -- Get the WooCommerce token get "/api/wootoken" $ do - session <- param "session" - user <- liftAndCatchIO $ run (findUser session) + session <- formParam "session" + user <- liftIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status unauthorized401 Just u -> do - owner <- liftAndCatchIO $ run (findOwner $ uaddress u) + owner <- liftIO $ run (findOwner $ uaddress u) case cast' . Doc =<< owner of Nothing -> status internalServerError500 Just o -> do - res <- liftAndCatchIO $ run (findWooToken $ o_id o) + res <- liftIO $ run (findWooToken $ o_id o) let t1 = cast' . Doc =<< res case t1 of Nothing -> status noContent204 @@ -901,28 +901,28 @@ routes pipe config = do , "siteurl" .= w_url t ]) post "/api/wootoken" $ do - oid <- param "ownerid" - session <- param "session" - user <- liftAndCatchIO $ run (findUser session) + oid <- formParam "ownerid" + session <- formParam "session" + user <- liftIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status unauthorized401 Just u -> do - res <- liftAndCatchIO $ run (findOwnerById oid) + res <- liftIO $ run (findOwnerById oid) case cast' . Doc =<< res of Nothing -> status badRequest400 Just o -> do if oaddress o == uaddress u then do tk <- liftIO generateToken - liftAndCatchIO $ run (generateWooToken o tk) + liftIO $ run (generateWooToken o tk) status accepted202 else status forbidden403 -- Authenticate the WooCommerce plugin get "/auth" $ do - oid <- param "ownerid" - t <- param "token" - siteurl <- param "siteurl" - res <- liftAndCatchIO $ run (findWooToken $ Just (read oid)) + oid <- queryParam "ownerid" + t <- queryParam "token" + siteurl <- queryParam "siteurl" + res <- liftIO $ run (findWooToken $ Just (read oid)) let c1 = cast' . Doc =<< res case c1 of Nothing -> do @@ -934,7 +934,7 @@ routes pipe config = do if blk3Hash t == blk3Hash (T.unpack $ w_token c) then if isNothing (w_url c) then do - liftAndCatchIO $ run (addUrl c siteurl) + liftIO $ run (addUrl c siteurl) status ok200 Web.Scotty.json (object @@ -972,18 +972,20 @@ routes pipe config = do where blk3Hash :: String -> String blk3Hash s = show - (BLK.hash [BA.pack . BS.unpack . C.pack $ s :: BA.Bytes] :: BLK.Digest + (BLK.hash + Nothing + [BA.pack . BS.unpack . C.pack $ s :: BA.Bytes] :: BLK.Digest BLK.DEFAULT_DIGEST_LEN) get "/woopayment" $ do - oid <- param "ownerid" - t <- param "token" - ordId <- param "order_id" - date <- param "date" - curr <- param "currency" - amount <- param "amount" - sUrl <- param "siteurl" - orderKey <- param "orderkey" - res <- liftAndCatchIO $ run (findWooToken $ Just (read oid)) + oid <- queryParam "ownerid" + t <- queryParam "token" + ordId <- queryParam "order_id" + date <- queryParam "date" + curr <- queryParam "currency" + amount <- queryParam "amount" + sUrl <- queryParam "siteurl" + orderKey <- queryParam "orderkey" + res <- liftIO $ run (findWooToken $ Just (read oid)) let c = cast' . Doc =<< res case c of Nothing -> do @@ -995,7 +997,7 @@ routes pipe config = do (E.decodeUtf8With lenientDecode . B64.decodeLenient . C.pack) sUrl == fromMaybe "" (w_url x) then do - zecPriceDb <- liftAndCatchIO (run (findPrice curr)) + zecPriceDb <- liftIO (run (findPrice curr)) let zecPrice = parseZGoPrice =<< zecPriceDb case zecPrice of Nothing -> do @@ -1004,8 +1006,7 @@ routes pipe config = do (object ["message" .= ("Currency not supported" :: String)]) Just zP -> do ownerDb <- - liftAndCatchIO $ - run (findOwnerById (T.pack . show $ w_owner x)) + liftIO $ run (findOwnerById (T.pack . show $ w_owner x)) let owner = cast' . Doc =<< ownerDb case owner of Nothing -> do @@ -1046,7 +1047,7 @@ routes pipe config = do 0 0 0 - newId <- liftAndCatchIO $ run (insertWooOrder newOrder) + newId <- liftIO $ run (insertWooOrder newOrder) status ok200 Web.Scotty.json (object ["order" .= show newId, "token" .= tk]) @@ -1060,8 +1061,8 @@ routes pipe config = do Web.Scotty.json (object ["message" .= ("Incorrect plugin config" :: String)]) get "/checkuser" $ do - sess <- param "session" - user <- liftAndCatchIO $ run (findUser sess) + sess <- formParam "session" + user <- liftIO $ run (findUser sess) case parseUserBson =<< user of Nothing -> status noContent204 Just u -> do @@ -1069,8 +1070,8 @@ routes pipe config = do Web.Scotty.json (object ["validated" .= uvalidated u]) --Get user associated with session get "/api/user" $ do - sess <- param "session" - user <- liftAndCatchIO $ run (findUser sess) + sess <- formParam "session" + user <- liftIO $ run (findUser sess) case user of Nothing -> status noContent204 Just u -> do @@ -1082,13 +1083,14 @@ routes pipe config = do ]) --Validate user, updating record post "/validateuser" $ do - providedPin <- param "pin" - sess <- param "session" + providedPin <- formParam "pin" + sess <- formParam "session" let pinHash = BLK.hash + Nothing [ BA.pack . BS.unpack . C.pack . T.unpack $ providedPin <> sess :: BA.Bytes ] - user <- liftAndCatchIO $ run (findUser sess) + user <- liftIO $ run (findUser sess) case user of Nothing -> status noContent204 --`debug` "No user match" Just u -> do @@ -1102,30 +1104,29 @@ routes pipe config = do (pinHash :: BLK.Digest BLK.DEFAULT_DIGEST_LEN)) if ans then do - liftAndCatchIO $ run (validateUser sess) + liftIO $ run (validateUser sess) status accepted202 else status noContent204 --`debug` ("Pins didn't match: " ++ providedPin ++ " " ++ T.unpack (upin pUser)) --Delete user Web.Scotty.delete "/api/user/:id" $ do - userId <- param "id" - session <- param "session" + userId <- captureParam "id" + session <- captureParam "session" let r = mkRegex "^[a-f0-9]{24}$" if matchTest r userId then do - u <- liftAndCatchIO $ run (findUserById userId) + u <- liftIO $ run (findUserById userId) case cast' . Doc =<< u of Nothing -> status badRequest400 Just u' -> if session == usession u' then do - liftAndCatchIO $ run (deleteUser userId) + liftIO $ run (deleteUser userId) status ok200 else status forbidden403 else status badRequest400 --Get current blockheight from Zcash node get "/blockheight" $ do - blockInfo <- - liftAndCatchIO $ makeZcashCall nodeUser nodePwd "getblock" ["-1"] + blockInfo <- liftIO $ makeZcashCall nodeUser nodePwd "getblock" ["-1"] let content = getResponseBody blockInfo :: RpcResponse Block if isNothing (err content) then do @@ -1137,12 +1138,12 @@ routes pipe config = do get "/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress]) --Get owner by address get "/api/owner" $ do - session <- param "session" - user <- liftAndCatchIO $ run (findUser session) + session <- formParam "session" + user <- liftIO $ run (findUser session) case parseUserBson =<< user of Nothing -> status noContent204 Just u -> do - owner <- liftAndCatchIO $ run (findOwner $ uaddress u) + owner <- liftIO $ run (findOwner $ uaddress u) case cast' . Doc =<< owner of Nothing -> status noContent204 Just o -> do @@ -1153,8 +1154,8 @@ routes pipe config = do , "owner" .= getOwnerSettings o ]) get "/ownerid" $ do - id <- param "id" - owner <- liftAndCatchIO $ run (findOwnerById id) + id <- formParam "id" + owner <- liftIO $ run (findOwnerById id) case owner of Nothing -> status noContent204 Just o -> do @@ -1170,15 +1171,15 @@ routes pipe config = do ]) --Upsert owner to DB post "/api/owner" $ do - s <- param "session" - u <- liftAndCatchIO $ run (findUser s) + s <- formParam "session" + u <- liftIO $ run (findUser s) o <- jsonData now <- liftIO getCurrentTime let q = payload (o :: Payload OwnerData) case parseUserBson =<< u of Nothing -> status internalServerError500 Just u' -> do - liftAndCatchIO $ + liftIO $ run $ upsertOwner $ Owner @@ -1210,8 +1211,8 @@ routes pipe config = do False status accepted202 post "/api/ownersettings" $ do - s <- param "session" - u <- liftAndCatchIO $ run (findUser s) + s <- formParam "session" + u <- liftIO $ run (findUser s) o <- jsonData now <- liftIO getCurrentTime let q = payload (o :: Payload OwnerSettings) @@ -1220,12 +1221,12 @@ routes pipe config = do Just u' -> do if os_address q == uaddress u' then do - liftAndCatchIO $ run $ updateOwnerSettings q + liftIO $ run $ updateOwnerSettings q status accepted202 else status noContent204 post "/api/ownervk" $ do - s <- param "session" - u <- liftAndCatchIO $ run (findUser s) + s <- formParam "session" + u <- liftIO $ run (findUser s) o <- jsonData let q = payload (o :: Payload String) let qRaw = decodeBech32 $ C.pack q @@ -1242,12 +1243,12 @@ routes pipe config = do qBytes (bytes . decodeBech32 . C.pack . T.unpack $ uaddress u') then do - owner <- liftAndCatchIO $ run (findOwner $ uaddress u') + owner <- liftIO $ run (findOwner $ uaddress u') case cast' . Doc =<< owner of Nothing -> status badRequest400 Just o' -> do unless (oviewkey o' /= "") $ do - liftAndCatchIO $ run (upsertViewingKey o' q) + liftIO $ run (upsertViewingKey o' q) status created201 else status forbidden403 else case decodeUfvk (C.pack q) of @@ -1260,14 +1261,12 @@ routes pipe config = do (C.pack q) (C.pack . T.unpack $ uaddress u') then do - owner <- - liftAndCatchIO $ run (findOwner $ uaddress u') + owner <- liftIO $ run (findOwner $ uaddress u') case cast' . Doc =<< owner of Nothing -> status badRequest400 Just o' -> do unless (oviewkey o' /= "") $ do - liftAndCatchIO $ - run (upsertViewingKey o' q) + liftIO $ run (upsertViewingKey o' q) status created201 else status forbidden403 Nothing -> do @@ -1276,27 +1275,24 @@ routes pipe config = do (bytes . decodeBech32 . C.pack . T.unpack $ uaddress u') then do - owner <- - liftAndCatchIO $ run (findOwner $ uaddress u') + owner <- liftIO $ run (findOwner $ uaddress u') case cast' . Doc =<< owner of Nothing -> status badRequest400 Just o' -> do unless (oviewkey o' /= "") $ do - liftAndCatchIO $ - run (upsertViewingKey o' q) + liftIO $ run (upsertViewingKey o' q) status created201 else status forbidden403 --Get items associated with the given address get "/api/items" $ do - session <- param "session" - user <- liftAndCatchIO $ run (findUser session) + session <- formParam "session" + user <- liftIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status forbidden403 Just u -> do - items <- liftAndCatchIO $ run (findItems $ uaddress u) - case items of - [] -> status noContent204 - _ -> do + items <- liftIO $ run (findItems $ uaddress u) + if not (null items) + then do let pItems = map (cast' . Doc) items :: [Maybe Item] status ok200 Web.Scotty.json @@ -1304,41 +1300,42 @@ routes pipe config = do [ "message" .= ("Items found!" :: String) , "items" .= toJSON pItems ]) + else status noContent204 --Upsert item post "/api/item" $ do i <- jsonData - session <- param "session" - user <- liftAndCatchIO $ run (findUser session) + session <- formParam "session" + user <- liftIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status forbidden403 Just u -> do let q = payload (i :: Payload Item) if uaddress u == iowner q then do - _ <- liftAndCatchIO $ run (upsertItem q) + _ <- liftIO $ run (upsertItem q) status created201 else status forbidden403 --Delete item Web.Scotty.delete "/api/item/:id" $ do - session <- param "session" - oId <- param "id" - u' <- liftAndCatchIO $ checkUser run session + session <- formParam "session" + oId <- captureParam "id" + u' <- liftIO $ checkUser run session case u' of Nothing -> status forbidden403 Just u -> do - i <- liftAndCatchIO $ run (findItemById oId) + i <- liftIO $ run (findItemById oId) case cast' . Doc =<< i of Nothing -> status badRequest400 Just i' -> do if iowner i' == uaddress u then do - liftAndCatchIO $ run (deleteItem oId) + liftIO $ run (deleteItem oId) status ok200 else status forbidden403 --Get price for Zcash get "/price" $ do - curr <- param "currency" - pr <- liftAndCatchIO $ run (findPrice curr) + curr <- formParam "currency" + pr <- liftIO $ run (findPrice curr) case parseZGoPrice =<< pr of Nothing -> do status noContent204 @@ -1347,15 +1344,15 @@ routes pipe config = do (object ["message" .= ("Price found!" :: String), "price" .= toJSON p]) --Get all closed orders for the address get "/api/allorders" $ do - session <- param "session" - user <- liftAndCatchIO $ run (findUser session) + session <- formParam "session" + user <- liftIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status unauthorized401 Just u -> do - myOrders <- liftAndCatchIO $ run (findAllOrders $ uaddress u) - case myOrders of - [] -> status noContent204 - _ -> do + myOrders <- liftIO $ run (findAllOrders $ uaddress u) + if null myOrders + then status noContent204 + else do let pOrders = map (cast' . Doc) myOrders :: [Maybe ZGoOrder] status ok200 Web.Scotty.json @@ -1365,18 +1362,18 @@ routes pipe config = do ]) --Get order by id for receipts get "/order/:id" $ do - oId <- param "id" - token <- param "token" + oId <- captureParam "id" + token <- formParam "token" let r = mkRegex "^[a-f0-9]{24}$" if matchTest r oId then do - myOrder <- liftAndCatchIO $ run (findOrderById oId) + myOrder <- liftIO $ run (findOrderById oId) case cast' . Doc =<< myOrder of Nothing -> status noContent204 Just pOrder -> do if qtoken pOrder == token then do - shop <- liftAndCatchIO $ run (findOwner $ qaddress pOrder) + shop <- liftIO $ run (findOwner $ qaddress pOrder) case cast' . Doc =<< shop of Nothing -> status badRequest400 Just s -> do @@ -1391,8 +1388,8 @@ routes pipe config = do else status badRequest400 --Get order by session get "/api/order" $ do - sess <- param "session" - myOrder <- liftAndCatchIO $ run (findOrder sess) + sess <- formParam "session" + myOrder <- liftIO $ run (findOrder sess) case myOrder of Nothing -> status noContent204 Just o -> do @@ -1412,7 +1409,7 @@ routes pipe config = do {-let q = payload (newOrder :: Payload ZGoOrder)-} {-_ <- liftIO $ run (upsertXeroOrder q)-} {-myOrder <--} - {-liftAndCatchIO $-} + {-liftIO $-} {-run (findXeroOrder (qaddress q) (qexternalInvoice q) (qshortCode q))-} {-case myOrder of-} {-Nothing -> status noContent204-} @@ -1431,12 +1428,12 @@ routes pipe config = do post "/api/order" $ do newOrder <- jsonData let q = payload (newOrder :: Payload ZGoOrder) - session <- param "session" - user <- liftAndCatchIO $ run (findUser session) + session <- formParam "session" + user <- liftIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status unauthorized401 Just u -> do - owner <- liftAndCatchIO $ run $ findOwner (uaddress u) + owner <- liftIO $ run $ findOwner (uaddress u) case cast' . Doc =<< owner of Nothing -> status badRequest400 Just o -> do @@ -1448,8 +1445,7 @@ routes pipe config = do if ovat o then ovatValue o else 0 - dbOrder <- - liftAndCatchIO $ run (findOrderById $ maybe "0" show (q_id q)) + dbOrder <- liftIO $ run (findOrderById $ maybe "0" show (q_id q)) case cast' . Doc =<< dbOrder of Nothing -> do if uaddress u == qaddress q @@ -1458,7 +1454,7 @@ routes pipe config = do then do t <- liftIO generateToken _ <- - liftAndCatchIO $ + liftIO $ run (upsertOrder (setOrderToken (T.pack t) q) @@ -1467,7 +1463,7 @@ routes pipe config = do status created201 else do _ <- - liftAndCatchIO $ + liftIO $ access pipe master @@ -1484,7 +1480,7 @@ routes pipe config = do then do t <- liftIO generateToken _ <- - liftAndCatchIO $ + liftIO $ run (upsertOrder (setOrderToken (T.pack t) q) @@ -1493,7 +1489,7 @@ routes pipe config = do status created201 else do _ <- - liftAndCatchIO $ + liftIO $ access pipe master @@ -1504,62 +1500,62 @@ routes pipe config = do else status forbidden403 --Delete order Web.Scotty.delete "/api/order/:id" $ do - oId <- param "id" - session <- param "session" - o <- liftAndCatchIO $ run (findOrderById oId) + oId <- captureParam "id" + session <- formParam "session" + o <- liftIO $ run (findOrderById oId) case cast' . Doc =<< o of Nothing -> status badRequest400 Just order -> do if qsession order == session then do - liftAndCatchIO $ run (deleteOrder oId) + liftIO $ run (deleteOrder oId) status ok200 else status forbidden403 -- Get language for component get "/getmainlang" $ do - lang <- param "lang" - txtPack' <- liftAndCatchIO $ run (findLangComponent lang "main") + lang <- queryParam "lang" + txtPack' <- liftIO $ run (findLangComponent lang "main") case cast' . Doc =<< txtPack' of Nothing -> status noContent204 Just textPack -> do status ok200 Web.Scotty.json $ toJSON (textPack :: LangComponent) get "/getscanlang" $ do - lang <- param "lang" - txtPack' <- liftAndCatchIO $ run (findLangComponent lang "scan") + lang <- queryParam "lang" + txtPack' <- liftIO $ run (findLangComponent lang "scan") case cast' . Doc =<< txtPack' of Nothing -> status noContent204 Just textPack -> do status ok200 Web.Scotty.json $ toJSON (textPack :: LangComponent) get "/getloginlang" $ do - lang <- param "lang" - txtPack' <- liftAndCatchIO $ run (findLangComponent lang "login") + lang <- queryParam "lang" + txtPack' <- liftIO $ run (findLangComponent lang "login") case cast' . Doc =<< txtPack' of Nothing -> status noContent204 Just textPack -> do status ok200 Web.Scotty.json $ toJSON (textPack :: LangComponent) get "/getinvoicelang" $ do - lang <- param "lang" - txtPack' <- liftAndCatchIO $ run (findLangComponent lang "invoice") + lang <- queryParam "lang" + txtPack' <- liftIO $ run (findLangComponent lang "invoice") case cast' . Doc =<< txtPack' of Nothing -> status noContent204 Just textPack -> do status ok200 Web.Scotty.json $ toJSON (textPack :: LangComponent) get "/getpmtservicelang" $ do - lang <- param "lang" - txtPack' <- liftAndCatchIO $ run (findLangComponent lang "pmtservice") + lang <- queryParam "lang" + txtPack' <- liftIO $ run (findLangComponent lang "pmtservice") case cast' . Doc =<< txtPack' of Nothing -> status noContent204 Just textPack -> do status ok200 Web.Scotty.json $ toJSON (textPack :: LangComponent) get "/api/getlang" $ do - component <- param "component" - lang <- param "lang" - txtPack' <- liftAndCatchIO $ run (findLangComponent lang component) + component <- queryParam "component" + lang <- queryParam "lang" + txtPack' <- liftIO $ run (findLangComponent lang component) let txtPack = cast' . Doc =<< txtPack' case txtPack of Nothing -> status noContent204 @@ -1569,7 +1565,7 @@ routes pipe config = do {-post "/api/setlang" $ do-} {-langComp <- jsonData-} {-_ <--} - {-liftAndCatchIO $-} + {-liftIO $-} {-mapM (run . loadLangComponent) (langComp :: [LangComponent])-} {-status created201-} {-(MonadIO m, FromJSON a)-} @@ -2007,17 +2003,17 @@ scanTxNative config pipe = do filterTx t = not (null (maybe [] rt_shieldedOutputs t)) || not (null (maybe [] rt_orchardActions t)) - extractTxs :: Maybe BlockResponse -> [T.Text] + extractTxs :: Maybe BlockResponse -> [HexString] extractTxs = maybe [] bl_txs getTxData :: - BS.ByteString -> BS.ByteString -> T.Text -> IO (Maybe RawTxResponse) + BS.ByteString -> BS.ByteString -> HexString -> IO (Maybe RawTxResponse) getTxData nodeUser nodePwd txid = do txInfo <- makeZcashCall nodeUser nodePwd "getrawtransaction" - [Data.Aeson.String txid, Number $ SC.scientific 1 0] + [Data.Aeson.String (toText txid), Number $ SC.scientific 1 0] let content = getResponseBody txInfo :: RpcResponse RawTxResponse if isNothing (err content) then return $ result content @@ -2075,7 +2071,7 @@ scanTxNative config pipe = do (E.decodeUtf8Lenient $ a_memo n) recordPayment :: Pipe -> T.Text -> T.Text -> ZcashTx -> IO () recordPayment p dbName z x = do - let zM = runParser pZGoMemo (T.unpack . ztxid $ x) (zmemo x) + let zM = runParser pZGoMemo (T.unpack . toText . ztxid $ x) (zmemo x) case zM of Right m -> do case m_orderId m of @@ -2165,14 +2161,14 @@ instance Val BlockResponse where h <- B.lookup "height" d t <- B.lookup "time" d txs <- B.lookup "tx" d - Just (BlockResponse c h t txs) + Just (BlockResponse c h t (map fromText txs)) cast' _ = Nothing val (BlockResponse c h t txs) = Doc [ "confirmations" =: c , "height" =: h , "time" =: t - , "tx" =: txs + , "tx" =: (map toText txs) , "network" =: ("mainnet" :: String) ] diff --git a/zgo-backend.cabal b/zgo-backend.cabal index dc289d8..91293f4 100644 --- a/zgo-backend.cabal +++ b/zgo-backend.cabal @@ -1,11 +1,11 @@ -cabal-version: 1.12 +cabal-version: 3.0 -- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: zgo-backend -version: 1.8.1 +version: 1.9.0 synopsis: Haskell Back-end for the ZGo point-of-sale application description: Please see the README at category: Web @@ -20,10 +20,6 @@ extra-source-files: CHANGELOG.md zgo.cfg -source-repository head - type: git - location: https://git.vergara.tech/Vergara_Tech/zgo-backend - library exposed-modules: Config @@ -37,8 +33,6 @@ library Xero ZGoBackend ZGoTx - other-modules: - Paths_zgo_backend hs-source-dirs: src build-depends: @@ -83,13 +77,11 @@ library executable zgo-backend-exe main-is: Server.hs - other-modules: - Tasks - TokenRefresh - Paths_zgo_backend hs-source-dirs: app ghc-options: -main-is Server -threaded -rtsopts -with-rtsopts=-N -Wall + pkgconfig-depends: + rustzcash_wrapper build-depends: aeson , base @@ -98,7 +90,7 @@ executable zgo-backend-exe , http-conduit , http-types , megaparsec - , mongoDB + , mongoDB >=2.7.1.4 , scotty , securemem , text @@ -111,13 +103,11 @@ executable zgo-backend-exe executable zgo-tasks main-is: Tasks.hs - other-modules: - Server - TokenRefresh - Paths_zgo_backend hs-source-dirs: app ghc-options: -main-is Tasks -threaded -rtsopts -with-rtsopts=-N -Wall + pkgconfig-depends: + rustzcash_wrapper build-depends: base , megaparsec @@ -131,13 +121,11 @@ executable zgo-tasks executable zgo-token-refresh main-is: TokenRefresh.hs - other-modules: - Server - Tasks - Paths_zgo_backend hs-source-dirs: app ghc-options: -main-is TokenRefresh -threaded -rtsopts -with-rtsopts=-N -Wall + pkgconfig-depends: + rustzcash_wrapper build-depends: aeson , base @@ -160,11 +148,11 @@ executable zgo-token-refresh test-suite zgo-backend-test type: exitcode-stdio-1.0 main-is: Spec.hs - other-modules: - Paths_zgo_backend hs-source-dirs: test ghc-options: -threaded -rtsopts -with-rtsopts=-N -main-is Spec + pkgconfig-depends: + rustzcash_wrapper build-depends: QuickCheck , aeson -- 2.43.0 From e3935c29f60d84be78064e0fd14cfce98919fd6c Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Mon, 20 May 2024 11:18:35 -0500 Subject: [PATCH 6/9] Update tests --- test/Spec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Spec.hs b/test/Spec.hs index 35d60cf..61742db 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -36,7 +36,7 @@ import Test.QuickCheck.Gen import Test.QuickCheck.Monadic import Text.Megaparsec import User -import Web.Scotty +import Web.Scotty hiding (getResponseStatus) import WooCommerce import Xero import ZGoBackend -- 2.43.0 From f9eb0e78f0c8a5b5c6ab6f19c7300a681b239bf7 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Mon, 20 May 2024 11:22:10 -0500 Subject: [PATCH 7/9] Update ignores --- .gitignore | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index c368d45..e909f1e 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ .stack-work/ -*~ \ No newline at end of file +dist-newstyle/ +*~ -- 2.43.0 From f19aa99ca9cbb8d01edab93fabf243475c524296 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Mon, 20 May 2024 15:20:47 -0500 Subject: [PATCH 8/9] Updates for new versions of libraries mongoDB Scotty --- src/ZGoBackend.hs | 62 ++++++++++++++++++++++++----------------------- test/Spec.hs | 19 ++++++++------- zgo-backend.cabal | 1 + 3 files changed, 43 insertions(+), 39 deletions(-) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 29f62ef..ef88e2e 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -634,8 +634,8 @@ routes pipe config = do , "xeroConfig" .= toJSON (c :: Xero) ]) get "/api/xerotoken" $ do - code <- formParam "code" - session <- formParam "session" + code <- queryParam "code" + session <- queryParam "session" user <- liftIO $ run (findUser session) xeroConfig <- liftIO $ run findXero case cast' . Doc =<< xeroConfig of @@ -850,7 +850,7 @@ routes pipe config = do ]) -- Get the xeroaccount code get "/api/xeroaccount" $ do - session <- formParam "session" + session <- queryParam "session" user <- liftIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status unauthorized401 @@ -868,8 +868,8 @@ routes pipe config = do ]) -- Save the xeroaccount code post "/api/xeroaccount" $ do - session <- formParam "session" - c <- formParam "code" + session <- queryParam "session" + c <- queryParam "code" user <- liftIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status unauthorized401 @@ -879,7 +879,7 @@ routes pipe config = do status accepted202 -- Get the WooCommerce token get "/api/wootoken" $ do - session <- formParam "session" + session <- queryParam "session" user <- liftIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status unauthorized401 @@ -901,8 +901,8 @@ routes pipe config = do , "siteurl" .= w_url t ]) post "/api/wootoken" $ do - oid <- formParam "ownerid" - session <- formParam "session" + oid <- queryParam "ownerid" + session <- queryParam "session" user <- liftIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status unauthorized401 @@ -1061,7 +1061,7 @@ routes pipe config = do Web.Scotty.json (object ["message" .= ("Incorrect plugin config" :: String)]) get "/checkuser" $ do - sess <- formParam "session" + sess <- queryParam "session" user <- liftIO $ run (findUser sess) case parseUserBson =<< user of Nothing -> status noContent204 @@ -1070,7 +1070,7 @@ routes pipe config = do Web.Scotty.json (object ["validated" .= uvalidated u]) --Get user associated with session get "/api/user" $ do - sess <- formParam "session" + sess <- queryParam "session" user <- liftIO $ run (findUser sess) case user of Nothing -> status noContent204 @@ -1083,8 +1083,8 @@ routes pipe config = do ]) --Validate user, updating record post "/validateuser" $ do - providedPin <- formParam "pin" - sess <- formParam "session" + providedPin <- queryParam "pin" + sess <- queryParam "session" let pinHash = BLK.hash Nothing @@ -1092,11 +1092,11 @@ routes pipe config = do ] user <- liftIO $ run (findUser sess) case user of - Nothing -> status noContent204 --`debug` "No user match" + Nothing -> status noContent204 `debug` "No user match" Just u -> do let parsedUser = parseUserBson u case parsedUser of - Nothing -> status noContent204 --`debug` "Couldn't parse user" + Nothing -> status noContent204 `debug` "Couldn't parse user" Just pUser -> do let ans = upin pUser == @@ -1106,11 +1106,13 @@ routes pipe config = do then do liftIO $ run (validateUser sess) status accepted202 - else status noContent204 --`debug` ("Pins didn't match: " ++ providedPin ++ " " ++ T.unpack (upin pUser)) + else status noContent204 `debug` + ("Pins didn't match: " ++ + T.unpack providedPin ++ " " ++ T.unpack (upin pUser)) --Delete user Web.Scotty.delete "/api/user/:id" $ do userId <- captureParam "id" - session <- captureParam "session" + session <- queryParam "session" let r = mkRegex "^[a-f0-9]{24}$" if matchTest r userId then do @@ -1138,7 +1140,7 @@ routes pipe config = do get "/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress]) --Get owner by address get "/api/owner" $ do - session <- formParam "session" + session <- queryParam "session" user <- liftIO $ run (findUser session) case parseUserBson =<< user of Nothing -> status noContent204 @@ -1154,7 +1156,7 @@ routes pipe config = do , "owner" .= getOwnerSettings o ]) get "/ownerid" $ do - id <- formParam "id" + id <- queryParam "id" owner <- liftIO $ run (findOwnerById id) case owner of Nothing -> status noContent204 @@ -1171,7 +1173,7 @@ routes pipe config = do ]) --Upsert owner to DB post "/api/owner" $ do - s <- formParam "session" + s <- queryParam "session" u <- liftIO $ run (findUser s) o <- jsonData now <- liftIO getCurrentTime @@ -1211,7 +1213,7 @@ routes pipe config = do False status accepted202 post "/api/ownersettings" $ do - s <- formParam "session" + s <- queryParam "session" u <- liftIO $ run (findUser s) o <- jsonData now <- liftIO getCurrentTime @@ -1225,7 +1227,7 @@ routes pipe config = do status accepted202 else status noContent204 post "/api/ownervk" $ do - s <- formParam "session" + s <- queryParam "session" u <- liftIO $ run (findUser s) o <- jsonData let q = payload (o :: Payload String) @@ -1285,7 +1287,7 @@ routes pipe config = do else status forbidden403 --Get items associated with the given address get "/api/items" $ do - session <- formParam "session" + session <- queryParam "session" user <- liftIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status forbidden403 @@ -1304,7 +1306,7 @@ routes pipe config = do --Upsert item post "/api/item" $ do i <- jsonData - session <- formParam "session" + session <- queryParam "session" user <- liftIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status forbidden403 @@ -1317,7 +1319,7 @@ routes pipe config = do else status forbidden403 --Delete item Web.Scotty.delete "/api/item/:id" $ do - session <- formParam "session" + session <- queryParam "session" oId <- captureParam "id" u' <- liftIO $ checkUser run session case u' of @@ -1334,7 +1336,7 @@ routes pipe config = do else status forbidden403 --Get price for Zcash get "/price" $ do - curr <- formParam "currency" + curr <- queryParam "currency" pr <- liftIO $ run (findPrice curr) case parseZGoPrice =<< pr of Nothing -> do @@ -1344,7 +1346,7 @@ routes pipe config = do (object ["message" .= ("Price found!" :: String), "price" .= toJSON p]) --Get all closed orders for the address get "/api/allorders" $ do - session <- formParam "session" + session <- queryParam "session" user <- liftIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status unauthorized401 @@ -1363,7 +1365,7 @@ routes pipe config = do --Get order by id for receipts get "/order/:id" $ do oId <- captureParam "id" - token <- formParam "token" + token <- queryParam "token" let r = mkRegex "^[a-f0-9]{24}$" if matchTest r oId then do @@ -1388,7 +1390,7 @@ routes pipe config = do else status badRequest400 --Get order by session get "/api/order" $ do - sess <- formParam "session" + sess <- queryParam "session" myOrder <- liftIO $ run (findOrder sess) case myOrder of Nothing -> status noContent204 @@ -1428,7 +1430,7 @@ routes pipe config = do post "/api/order" $ do newOrder <- jsonData let q = payload (newOrder :: Payload ZGoOrder) - session <- formParam "session" + session <- queryParam "session" user <- liftIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status unauthorized401 @@ -1501,7 +1503,7 @@ routes pipe config = do --Delete order Web.Scotty.delete "/api/order/:id" $ do oId <- captureParam "id" - session <- formParam "session" + session <- queryParam "session" o <- liftIO $ run (findOrderById oId) case cast' . Doc =<< o of Nothing -> status badRequest400 diff --git a/test/Spec.hs b/test/Spec.hs index 61742db..c8fa585 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -28,6 +28,7 @@ import Order import Owner import Payment import System.IO.Unsafe +import Test.HUnit hiding (assert) import Test.Hspec import Test.Hspec.Expectations.Json import Test.Hspec.QuickCheck @@ -169,7 +170,7 @@ main = do res <- httpLBS req getResponseStatus res `shouldBe` unauthorized401 describe "blockheight endpoint" $ do - it "returns a block number" $ do + xit "returns a block number" $ do req <- testGet "/blockheight" @@ -776,10 +777,10 @@ main = do describe "Database actions" $ do describe "authentication" $ do it "should succeed with good creds" $ \p -> do - r <- liftIO $ access p master "zgo" (auth "zgo" "zcashrules") + r <- liftIO $ access p master "test" (auth "zgo" "zcashrules") r `shouldBe` True it "should fail with bad creds" $ \p -> do - r <- liftIO $ access p master "zgo" (auth "user" "pwd") + r <- liftIO $ access p master "test" (auth "user" "pwd") r `shouldBe` False describe "ZGo Pro sessions" $ do it "find in DB" $ \p -> do @@ -793,21 +794,21 @@ main = do it "should update" $ \p -> do doc <- access p master "test" $ findPrice "usd" case doc of - Nothing -> True `shouldBe` False + Nothing -> assertFailure "couldn't find price" Just d -> do let q = parseZGoPrice d case q of - Nothing -> True `shouldBe` False + Nothing -> assertFailure "couldn't parse price" Just r -> do let t1 = ZGoBackend.timestamp r _ <- checkZcashPrices p "test" doc2 <- access p master "test" $ findPrice "usd" case doc2 of - Nothing -> True `shouldBe` False + Nothing -> assertFailure "couldn't find price" Just d2 -> do let q2 = parseZGoPrice d2 case q2 of - Nothing -> True `shouldBe` False + Nothing -> assertFailure "couldn't parse price" Just r2 -> do let t2 = ZGoBackend.timestamp r2 t2 `shouldSatisfy` (t1 <) @@ -1133,7 +1134,7 @@ testItemAdd i = do openDbConnection :: IO Pipe openDbConnection = do pipe <- connect $ host "127.0.0.1" - access pipe master "zgo" (auth "zgo" "zcashrules") + access pipe master "test" (auth "zgo" "zcashrules") return pipe -- | Close the MongoDB pipe @@ -1156,7 +1157,7 @@ startAPI :: Config -> IO () startAPI config = do putStrLn "Starting test server ..." pipe <- connect $ host $ c_dbHost config - c <- access pipe master "zgo" (auth (c_dbUser config) (c_dbPassword config)) + c <- access pipe master "test" (auth (c_dbUser config) (c_dbPassword config)) let appRoutes = routes pipe config _ <- forkIO (scotty 3000 appRoutes) _ <- diff --git a/zgo-backend.cabal b/zgo-backend.cabal index 91293f4..416f405 100644 --- a/zgo-backend.cabal +++ b/zgo-backend.cabal @@ -163,6 +163,7 @@ test-suite zgo-backend-test , hspec-expectations-json , hspec-wai , http-conduit + , HUnit , http-types , megaparsec , mongoDB -- 2.43.0 From ef61c5850422d4be5d7f490fc172bcee2ee97560 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Tue, 21 May 2024 12:19:43 -0500 Subject: [PATCH 9/9] Use updated version of borsh --- cabal.project | 4 ---- 1 file changed, 4 deletions(-) diff --git a/cabal.project b/cabal.project index 5429a99..836a722 100644 --- a/cabal.project +++ b/cabal.project @@ -14,7 +14,3 @@ source-repository-package location: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git tag: 335e804454cd30da2c526457be37e477f71e4665 -source-repository-package - type: git - location: https://github.com/khazaddum/borsh.git - tag: 5f49e963b0a6f784623c7d11ec500f3e3566dcfe -- 2.43.0