Compare commits
65 Commits
Author | SHA1 | Date |
---|---|---|
pitmutt | 87bab38720 | |
Rene Vergara | ab6cc7f413 | |
Rene Vergara | eaa11afa70 | |
pitmutt | 5ab5f9fb91 | |
Rene Vergara | 5d9d261eb9 | |
Rene Vergara | b670a1c15f | |
Rene Vergara | 9bd94843b4 | |
Rene Vergara | a20271db6d | |
Rene Vergara | 9c44d0443e | |
Rene Vergara | 50925970fc | |
Rene Vergara | 0c77163f31 | |
Rene Vergara | bd32d6c149 | |
Rene Vergara | 7daa9a9687 | |
Rene Vergara | 1c3dfd2da1 | |
Rene Vergara | a338c65892 | |
Rene Vergara | 2b2c3ba70e | |
Rene Vergara | 056ddff816 | |
Rene Vergara | ac86d1ee59 | |
Rene Vergara | 5788a26880 | |
Rene Vergara | ec72015524 | |
Rene Vergara | 19b352c381 | |
Rene Vergara | 4558dfb8da | |
Rene Vergara | a3eb5d29ee | |
Rene Vergara | c2be91dfcc | |
Rene Vergara | d7ced42d86 | |
Rene Vergara | ccd9e8280e | |
Rene Vergara | b14a5cfb83 | |
Rene Vergara | f5dbde0ed6 | |
Rene Vergara | a2654a6f01 | |
Rene Vergara | cd5af6b907 | |
Rene Vergara | 68285fbc39 | |
Rene Vergara | 3f3cb9ef7c | |
Rene Vergara | 493d17abfd | |
Rene Vergara | bf740857b3 | |
Rene Vergara | cd259f244a | |
Rene Vergara | d235c56cfb | |
Rene Vergara | 74ba9d23f0 | |
Rene Vergara | 0224db1993 | |
Rene Vergara | 3ed60ae2dd | |
Rene Vergara | af22c0d71f | |
Rene Vergara | d90f7cdfea | |
Rene Vergara | 78c8b9ef5c | |
Rene Vergara | f0d1e933c6 | |
Rene Vergara | 5f32fd1142 | |
Rene Vergara | ae5606f4be | |
Rene Vergara | 82f6535765 | |
Rene Vergara | 0f4a5f547f | |
Rene Vergara | b36f1240b0 | |
Rene Vergara | 181f4bb749 | |
Rene Vergara | fb600aa5fc | |
Rene Vergara | 85bf0fef59 | |
Rene Vergara | a134947df6 | |
Rene Vergara | c5724d6d4a | |
Rene Vergara | 51ae13e53b | |
Rene Vergara | 4c13ddcc48 | |
Rene Vergara | fb436f1499 | |
Rene Vergara | 528fdebe61 | |
Rene Vergara | c58aa2f8c0 | |
Rene Vergara | 5ce72e5d95 | |
Rene Vergara | 7258af44c3 | |
Rene Vergara | 2b7ce1d186 | |
Rene Vergara | eda0f9336c | |
Rene Vergara | bacb2369e0 | |
Rene Vergara | e586321faf | |
Rene Vergara | e0f263f7f0 |
29
CHANGELOG.md
29
CHANGELOG.md
|
@ -4,6 +4,35 @@ 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
|
||||
|
||||
- Parser for Unified Addresses that validates the address
|
||||
- Tests for UA parsing from wallets
|
||||
- Function to scan new transactions using known viewing keys
|
||||
- Function to identify the owners and VKs needed for tx scans
|
||||
|
||||
### Changed
|
||||
|
||||
- Order endpoint updated to ensure orders belong to shop before adding to DB.
|
||||
- MongoDB driver updated to support MongoDB 6.
|
||||
- Full validation of Sapling addresses to parser.
|
||||
|
||||
### Removed
|
||||
|
||||
- `api/orderx` endpoint.
|
||||
- `makeZcashCall` function moved to the generic `zcash-haskell` library.
|
||||
- `RpcResponse`, `RpcCall` types moved to the generic `zcash-haskell` library.
|
||||
|
||||
## [1.7.0]
|
||||
|
||||
### Added
|
||||
|
|
7
COPYING
7
COPYING
|
@ -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.
|
||||
|
191
LICENSE
191
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 <insert your license name here>" 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.
|
||||
|
|
|
@ -23,10 +23,12 @@ main = do
|
|||
putStrLn "Connected to MongoDB!"
|
||||
checkZcashPrices pipe (c_dbName loadedConfig)
|
||||
scanZcash' loadedConfig pipe
|
||||
scanPayments loadedConfig pipe
|
||||
{-scanPayments loadedConfig pipe-}
|
||||
scanTxNative loadedConfig pipe
|
||||
checkPayments pipe (c_dbName loadedConfig)
|
||||
expireOwners pipe (c_dbName loadedConfig)
|
||||
updateLogins pipe loadedConfig
|
||||
expireProSessions pipe (c_dbName loadedConfig)
|
||||
loadTranslations pipe loadedConfig
|
||||
close pipe
|
||||
else fail "MongoDB connection failed!"
|
||||
|
|
|
@ -1,10 +1,10 @@
|
|||
name: zgo-backend
|
||||
version: 1.7.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
|
||||
|
|
142
src/Order.hs
142
src/Order.hs
|
@ -12,29 +12,31 @@ import Data.Time.Clock
|
|||
import Database.MongoDB
|
||||
import GHC.Generics
|
||||
import Test.QuickCheck
|
||||
import WooCommerce (WooToken(w_id))
|
||||
|
||||
-- | Type to represent a ZGo order
|
||||
data ZGoOrder =
|
||||
ZGoOrder
|
||||
{ q_id :: Maybe ObjectId
|
||||
, qaddress :: T.Text
|
||||
, qsession :: T.Text
|
||||
, qtimestamp :: UTCTime
|
||||
, qclosed :: Bool
|
||||
, qcurrency :: T.Text
|
||||
, qprice :: Double
|
||||
, qtotal :: Double
|
||||
, qtotalZec :: Double
|
||||
, qlines :: [LineItem]
|
||||
, qpaid :: Bool
|
||||
, qexternalInvoice :: T.Text
|
||||
, qshortCode :: T.Text
|
||||
, qtoken :: T.Text
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
data ZGoOrder = ZGoOrder
|
||||
{ q_id :: Maybe ObjectId
|
||||
, qaddress :: T.Text
|
||||
, qsession :: T.Text
|
||||
, qtimestamp :: UTCTime
|
||||
, qclosed :: Bool
|
||||
, qcurrency :: T.Text
|
||||
, qprice :: Double
|
||||
, qtotal :: Double
|
||||
, qtotalZec :: Double
|
||||
, qlines :: [LineItem]
|
||||
, qpaid :: Bool
|
||||
, qexternalInvoice :: T.Text
|
||||
, qshortCode :: T.Text
|
||||
, qtoken :: T.Text
|
||||
, qtax :: Double
|
||||
, qvat :: Double
|
||||
, qtip :: Double
|
||||
} deriving (Eq, Show, Generic)
|
||||
|
||||
instance ToJSON ZGoOrder where
|
||||
toJSON (ZGoOrder i a s ts c cur p t tZ l paid eI sC tk) =
|
||||
toJSON (ZGoOrder i a s ts c cur p t tZ l paid eI sC tk qT qV tip) =
|
||||
case i of
|
||||
Just oid ->
|
||||
object
|
||||
|
@ -52,6 +54,9 @@ instance ToJSON ZGoOrder where
|
|||
, "externalInvoice" .= eI
|
||||
, "shortCode" .= sC
|
||||
, "token" .= tk
|
||||
, "taxAmount" .= qT
|
||||
, "vatAmount" .= qV
|
||||
, "tipAmount" .= tip
|
||||
]
|
||||
Nothing ->
|
||||
object
|
||||
|
@ -69,6 +74,9 @@ instance ToJSON ZGoOrder where
|
|||
, "externalInvoice" .= eI
|
||||
, "shortCode" .= sC
|
||||
, "token" .= tk
|
||||
, "taxAmount" .= qT
|
||||
, "vatAmount" .= qV
|
||||
, "tipAmount" .= tip
|
||||
]
|
||||
|
||||
instance FromJSON ZGoOrder where
|
||||
|
@ -88,10 +96,13 @@ instance FromJSON ZGoOrder where
|
|||
eI <- obj .: "externalInvoice"
|
||||
sC <- obj .: "shortCode"
|
||||
tk <- obj .: "token"
|
||||
qT <- obj .: "taxAmount"
|
||||
qV <- obj .: "vatAmount"
|
||||
tip <- obj .: "tipAmount"
|
||||
pure $
|
||||
ZGoOrder
|
||||
(if not (null i)
|
||||
then Just (read i)
|
||||
then Just (read i :: ObjectId)
|
||||
else Nothing)
|
||||
a
|
||||
s
|
||||
|
@ -106,9 +117,12 @@ instance FromJSON ZGoOrder where
|
|||
eI
|
||||
sC
|
||||
tk
|
||||
qT
|
||||
qV
|
||||
tip
|
||||
|
||||
instance Val ZGoOrder where
|
||||
val (ZGoOrder i a s ts c cur p t tZ l pd eI sC tk) =
|
||||
val (ZGoOrder i a s ts c cur p t tZ l pd eI sC tk qT qV tip) =
|
||||
if isJust i
|
||||
then Doc
|
||||
[ "_id" =: i
|
||||
|
@ -125,6 +139,9 @@ instance Val ZGoOrder where
|
|||
, "externalInvoice" =: eI
|
||||
, "shortCode" =: sC
|
||||
, "token" =: tk
|
||||
, "taxAmount" =: qT
|
||||
, "vatAmount" =: qV
|
||||
, "tipAmount" =: tip
|
||||
]
|
||||
else Doc
|
||||
[ "address" =: a
|
||||
|
@ -140,6 +157,9 @@ instance Val ZGoOrder where
|
|||
, "externalInvoice" =: eI
|
||||
, "shortCode" =: sC
|
||||
, "token" =: tk
|
||||
, "taxAmount" =: qT
|
||||
, "vatAmount" =: qV
|
||||
, "tipAmount" =: tip
|
||||
]
|
||||
cast' (Doc d) = do
|
||||
i <- B.lookup "_id" d
|
||||
|
@ -156,17 +176,18 @@ instance Val ZGoOrder where
|
|||
eI <- B.lookup "externalInvoice" d
|
||||
sC <- B.lookup "shortCode" d
|
||||
tk <- B.lookup "token" d
|
||||
Just (ZGoOrder i a s ts c cur p t tZ l pd eI sC tk)
|
||||
qT <- B.lookup "taxAmount" d
|
||||
qV <- B.lookup "vatAmount" d
|
||||
tip <- B.lookup "tipAmount" d
|
||||
Just (ZGoOrder i a s ts c cur p t tZ l pd eI sC tk qT qV tip)
|
||||
cast' _ = Nothing
|
||||
|
||||
-- Type to represent an order line item
|
||||
data LineItem =
|
||||
LineItem
|
||||
{ lqty :: Double
|
||||
, lname :: T.Text
|
||||
, lcost :: Double
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
data LineItem = LineItem
|
||||
{ lqty :: Double
|
||||
, lname :: T.Text
|
||||
, lcost :: Double
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance ToJSON LineItem where
|
||||
toJSON (LineItem q n c) = object ["qty" .= q, "name" .= n, "cost" .= c]
|
||||
|
@ -189,33 +210,40 @@ instance Val LineItem where
|
|||
cast' _ = Nothing
|
||||
|
||||
-- Database actions
|
||||
upsertOrder :: ZGoOrder -> Action IO ()
|
||||
upsertOrder o = do
|
||||
let order = val $ updateOrderTotals o
|
||||
upsertOrder :: ZGoOrder -> Double -> Double -> Action IO ()
|
||||
upsertOrder o taxRate vatRate = do
|
||||
let order = val $ updateOrderTotals o taxRate vatRate
|
||||
case order of
|
||||
Doc d ->
|
||||
Doc d ->
|
||||
if isJust (q_id o)
|
||||
then upsert (select ["_id" =: q_id o] "orders") d
|
||||
else insert_ "orders" d
|
||||
then upsert (select ["_id" =: q_id o] "orders") d
|
||||
else insert_ "orders" d
|
||||
_ -> return ()
|
||||
|
||||
insertWooOrder :: ZGoOrder -> Action IO Database.MongoDB.Value
|
||||
insertWooOrder o = do
|
||||
let order = val $ updateOrderTotals o
|
||||
let order = val $ updateOrderTotals o 0 0
|
||||
case order of
|
||||
Doc d -> insert "orders" d
|
||||
_ -> fail "Couldn't parse order"
|
||||
|
||||
upsertXeroOrder :: ZGoOrder -> Action IO ()
|
||||
upsertXeroOrder o = do
|
||||
let order = val $ updateOrderTotals o
|
||||
let order = val $ updateOrderTotals o 0 0
|
||||
case order of
|
||||
Doc d -> upsert (select ["externalInvoice" =: qexternalInvoice o, "shortCode" =: qshortCode o] "orders") d
|
||||
Doc d ->
|
||||
upsert
|
||||
(select
|
||||
[ "externalInvoice" =: qexternalInvoice o
|
||||
, "shortCode" =: qshortCode o
|
||||
]
|
||||
"orders")
|
||||
d
|
||||
_ -> return ()
|
||||
|
||||
-- | Function to update order totals from items
|
||||
updateOrderTotals :: ZGoOrder -> ZGoOrder
|
||||
updateOrderTotals o =
|
||||
updateOrderTotals :: ZGoOrder -> Double -> Double -> ZGoOrder
|
||||
updateOrderTotals o taxRate vatRate =
|
||||
ZGoOrder
|
||||
(q_id o)
|
||||
(qaddress o)
|
||||
|
@ -224,36 +252,51 @@ updateOrderTotals o =
|
|||
(qclosed o)
|
||||
(qcurrency o)
|
||||
(qprice o)
|
||||
(newTotal o)
|
||||
(newTotal o taxRate vatRate)
|
||||
(if qprice o /= 0
|
||||
then roundZec (newTotal o / qprice o)
|
||||
then roundZec (newTotal o taxRate vatRate / qprice o)
|
||||
else 0)
|
||||
(qlines o)
|
||||
(qpaid o)
|
||||
(qexternalInvoice o)
|
||||
(qshortCode o)
|
||||
(qtoken o)
|
||||
(updateTax o taxRate)
|
||||
(updateTax o vatRate)
|
||||
(qtip o)
|
||||
where
|
||||
newTotal :: ZGoOrder -> Double
|
||||
newTotal x = foldr tallyItems 0 (qlines x)
|
||||
updateTax :: ZGoOrder -> Double -> Double
|
||||
updateTax x t = roundFiat $ itemsTotal (qlines x) * t / 100.0
|
||||
itemsTotal :: [LineItem] -> Double
|
||||
itemsTotal = foldr tallyItems 0
|
||||
newTotal :: ZGoOrder -> Double -> Double -> Double
|
||||
newTotal x tR vR =
|
||||
itemsTotal (qlines x) + updateTax x tR + updateTax x vR + qtip x
|
||||
tallyItems :: LineItem -> Double -> Double
|
||||
tallyItems y z = (lqty y * lcost y) + z
|
||||
|
||||
setOrderToken :: T.Text -> ZGoOrder -> ZGoOrder
|
||||
setOrderToken token (ZGoOrder i a s ts c cur p t tZ l pd eI sC tk) =
|
||||
ZGoOrder i a s ts c cur p t tZ l pd eI sC token
|
||||
setOrderToken token (ZGoOrder i a s ts c cur p t tZ l pd eI sC tk qT qV tip) =
|
||||
ZGoOrder i a s ts c cur p t tZ l pd eI sC token qT qV tip
|
||||
|
||||
findOrder :: T.Text -> Action IO (Maybe Document)
|
||||
findOrder s = findOne (select ["session" =: s, "closed" =: False] "orders")
|
||||
|
||||
findXeroOrder :: T.Text -> T.Text -> T.Text -> Action IO (Maybe Document)
|
||||
findXeroOrder a i s = findOne (select ["address" =: a, "externalInvoice" =: i, "shortCode" =: s] "orders")
|
||||
findXeroOrder a i s =
|
||||
findOne
|
||||
(select ["address" =: a, "externalInvoice" =: i, "shortCode" =: s] "orders")
|
||||
|
||||
findOrderById :: String -> Action IO (Maybe Document)
|
||||
findOrderById "0" = return Nothing
|
||||
findOrderById i = findOne (select ["_id" =: (read i :: B.ObjectId)] "orders")
|
||||
|
||||
findAllOrders :: T.Text -> Action IO [Document]
|
||||
findAllOrders a = rest =<< find (select ["address" =: a] "orders") {sort = ["timestamp" =: (negate 1 :: Int)]}
|
||||
findAllOrders a =
|
||||
rest =<<
|
||||
find
|
||||
(select ["address" =: a] "orders")
|
||||
{sort = ["timestamp" =: (negate 1 :: Int)]}
|
||||
|
||||
deleteOrder :: String -> Action IO ()
|
||||
deleteOrder i = deleteOne (select ["_id" =: (read i :: B.ObjectId)] "orders")
|
||||
|
@ -268,3 +311,6 @@ markOrderPaid (i, a) = do
|
|||
-- | Helper function to round to 8 decimal places
|
||||
roundZec :: Double -> Double
|
||||
roundZec n = fromInteger (round $ n * (10 ^ 8)) / (10.0 ^^ 8)
|
||||
|
||||
roundFiat :: Double -> Double
|
||||
roundFiat n = fromInteger (round $ n * (10 ^ 2)) / (10.0 ^^ 2)
|
||||
|
|
178
src/Owner.hs
178
src/Owner.hs
|
@ -14,38 +14,37 @@ import Database.MongoDB
|
|||
import GHC.Generics
|
||||
|
||||
-- | Type to represent a ZGo shop owner/business
|
||||
data Owner =
|
||||
Owner
|
||||
{ o_id :: Maybe ObjectId
|
||||
, oaddress :: T.Text
|
||||
, oname :: T.Text
|
||||
, ocurrency :: T.Text
|
||||
, otax :: Bool
|
||||
, otaxValue :: Double
|
||||
, ovat :: Bool
|
||||
, ovatValue :: Double
|
||||
, ofirst :: T.Text
|
||||
, olast :: T.Text
|
||||
, oemail :: T.Text
|
||||
, ostreet :: T.Text
|
||||
, ocity :: T.Text
|
||||
, ostate :: T.Text
|
||||
, opostal :: T.Text
|
||||
, ophone :: T.Text
|
||||
, owebsite :: T.Text
|
||||
, ocountry :: T.Text
|
||||
, opaid :: Bool
|
||||
, ozats :: Bool
|
||||
, oinvoices :: Bool
|
||||
, oexpiration :: UTCTime
|
||||
, opayconf :: Bool
|
||||
, oviewkey :: T.Text
|
||||
, ocrmToken :: T.Text
|
||||
}
|
||||
deriving (Eq, Show, Generic, Typeable)
|
||||
data Owner = Owner
|
||||
{ o_id :: Maybe ObjectId
|
||||
, oaddress :: T.Text
|
||||
, oname :: T.Text
|
||||
, ocurrency :: T.Text
|
||||
, otax :: Bool
|
||||
, otaxValue :: Double
|
||||
, ovat :: Bool
|
||||
, ovatValue :: Double
|
||||
, ofirst :: T.Text
|
||||
, olast :: T.Text
|
||||
, oemail :: T.Text
|
||||
, ostreet :: T.Text
|
||||
, ocity :: T.Text
|
||||
, ostate :: T.Text
|
||||
, opostal :: T.Text
|
||||
, ophone :: T.Text
|
||||
, owebsite :: T.Text
|
||||
, ocountry :: T.Text
|
||||
, opaid :: Bool
|
||||
, ozats :: Bool
|
||||
, oinvoices :: Bool
|
||||
, oexpiration :: UTCTime
|
||||
, opayconf :: Bool
|
||||
, oviewkey :: T.Text
|
||||
, ocrmToken :: T.Text
|
||||
, otips :: Bool
|
||||
} deriving (Eq, Show, Generic, Typeable)
|
||||
|
||||
instance ToJSON Owner where
|
||||
toJSON (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv eTs pc vk cT) =
|
||||
toJSON (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv eTs pc vk cT oT) =
|
||||
case i of
|
||||
Just oid ->
|
||||
object
|
||||
|
@ -74,6 +73,7 @@ instance ToJSON Owner where
|
|||
, "payconf" .= pc
|
||||
, "viewkey" .= vk
|
||||
, "crmToken" .= cT
|
||||
, "tips" .= oT
|
||||
]
|
||||
Nothing ->
|
||||
object
|
||||
|
@ -102,6 +102,7 @@ instance ToJSON Owner where
|
|||
, "payconf" .= pc
|
||||
, "viewkey" .= vk
|
||||
, "crmToken" .= cT
|
||||
, "tips" .= oT
|
||||
]
|
||||
|
||||
instance FromJSON Owner where
|
||||
|
@ -132,6 +133,7 @@ instance FromJSON Owner where
|
|||
pc <- obj .:? "payconf"
|
||||
vk <- obj .:? "viewkey"
|
||||
cT <- obj .:? "crmToken"
|
||||
oT <- obj .:? "tips"
|
||||
pure $
|
||||
Owner
|
||||
(if not (null i)
|
||||
|
@ -161,6 +163,7 @@ instance FromJSON Owner where
|
|||
(fromMaybe False pc)
|
||||
(fromMaybe "" vk)
|
||||
(fromMaybe "" cT)
|
||||
(fromMaybe False oT)
|
||||
|
||||
instance Val Owner where
|
||||
cast' (Doc d) = do
|
||||
|
@ -189,6 +192,7 @@ instance Val Owner where
|
|||
pc <- B.lookup "payconf" d
|
||||
vk <- B.lookup "viewKey" d
|
||||
cT <- B.lookup "crmToken" d
|
||||
oT <- B.lookup "tips" d
|
||||
Just
|
||||
(Owner
|
||||
i
|
||||
|
@ -215,9 +219,10 @@ instance Val Owner where
|
|||
ets
|
||||
pc
|
||||
vk
|
||||
cT)
|
||||
cT
|
||||
oT)
|
||||
cast' _ = Nothing
|
||||
val (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv ets pc vk cT) =
|
||||
val (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv ets pc vk cT oT) =
|
||||
case i of
|
||||
Just oid ->
|
||||
Doc
|
||||
|
@ -246,6 +251,7 @@ instance Val Owner where
|
|||
, "payconf" =: pc
|
||||
, "viewKey" =: vk
|
||||
, "crmToken" =: cT
|
||||
, "tips" =: oT
|
||||
]
|
||||
Nothing ->
|
||||
Doc
|
||||
|
@ -273,24 +279,23 @@ instance Val Owner where
|
|||
, "payconf" =: pc
|
||||
, "viewKey" =: vk
|
||||
, "crmToken" =: cT
|
||||
, "tips" =: oT
|
||||
]
|
||||
|
||||
-- | Type to represent informational data for Owners from UI
|
||||
data OwnerData =
|
||||
OwnerData
|
||||
{ od_first :: T.Text
|
||||
, od_last :: T.Text
|
||||
, od_name :: T.Text
|
||||
, od_street :: T.Text
|
||||
, od_city :: T.Text
|
||||
, od_state :: T.Text
|
||||
, od_postal :: T.Text
|
||||
, od_country :: T.Text
|
||||
, od_email :: T.Text
|
||||
, od_website :: T.Text
|
||||
, od_phone :: T.Text
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
data OwnerData = OwnerData
|
||||
{ od_first :: T.Text
|
||||
, od_last :: T.Text
|
||||
, od_name :: T.Text
|
||||
, od_street :: T.Text
|
||||
, od_city :: T.Text
|
||||
, od_state :: T.Text
|
||||
, od_postal :: T.Text
|
||||
, od_country :: T.Text
|
||||
, od_email :: T.Text
|
||||
, od_website :: T.Text
|
||||
, od_phone :: T.Text
|
||||
} deriving (Eq, Show, Generic)
|
||||
|
||||
instance FromJSON OwnerData where
|
||||
parseJSON =
|
||||
|
@ -308,25 +313,24 @@ instance FromJSON OwnerData where
|
|||
ph <- obj .: "phone"
|
||||
pure $ OwnerData f l n s c st p co e w ph
|
||||
|
||||
data OwnerSettings =
|
||||
OwnerSettings
|
||||
{ os_id :: Maybe ObjectId
|
||||
, os_address :: T.Text
|
||||
, os_name :: T.Text
|
||||
, os_currency :: T.Text
|
||||
, os_tax :: Bool
|
||||
, os_taxValue :: Double
|
||||
, os_vat :: Bool
|
||||
, os_vatValue :: Double
|
||||
, os_paid :: Bool
|
||||
, os_zats :: Bool
|
||||
, os_invoices :: Bool
|
||||
, os_expiration :: UTCTime
|
||||
, os_payconf :: Bool
|
||||
, os_crmToken :: T.Text
|
||||
, os_viewKey :: T.Text
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
data OwnerSettings = OwnerSettings
|
||||
{ os_id :: Maybe ObjectId
|
||||
, os_address :: T.Text
|
||||
, os_name :: T.Text
|
||||
, os_currency :: T.Text
|
||||
, os_tax :: Bool
|
||||
, os_taxValue :: Double
|
||||
, os_vat :: Bool
|
||||
, os_vatValue :: Double
|
||||
, os_paid :: Bool
|
||||
, os_zats :: Bool
|
||||
, os_invoices :: Bool
|
||||
, os_expiration :: UTCTime
|
||||
, os_payconf :: Bool
|
||||
, os_crmToken :: T.Text
|
||||
, os_viewKey :: T.Text
|
||||
, os_tips :: Bool
|
||||
} deriving (Eq, Show, Generic)
|
||||
|
||||
instance FromJSON OwnerSettings where
|
||||
parseJSON =
|
||||
|
@ -346,11 +350,28 @@ instance FromJSON OwnerSettings where
|
|||
pc <- obj .: "payconf"
|
||||
cT <- obj .: "crmToken"
|
||||
vK <- obj .: "viewkey"
|
||||
oT <- obj .: "tips"
|
||||
pure $
|
||||
OwnerSettings ((Just . read) =<< i) a n c t tV v vV p z inv e pc cT vK
|
||||
OwnerSettings
|
||||
((Just . read) =<< i)
|
||||
a
|
||||
n
|
||||
c
|
||||
t
|
||||
tV
|
||||
v
|
||||
vV
|
||||
p
|
||||
z
|
||||
inv
|
||||
e
|
||||
pc
|
||||
cT
|
||||
vK
|
||||
oT
|
||||
|
||||
instance ToJSON OwnerSettings where
|
||||
toJSON (OwnerSettings i a n c t tV v vV p z inv e pc cT vK) =
|
||||
toJSON (OwnerSettings i a n c t tV v vV p z inv e pc cT vK oT) =
|
||||
object
|
||||
[ "_id" .= maybe "" show i
|
||||
, "address" .= a
|
||||
|
@ -367,6 +388,7 @@ instance ToJSON OwnerSettings where
|
|||
, "payconf" .= pc
|
||||
, "crmToken" .= cT
|
||||
, "viewkey" .= keyObfuscate vK
|
||||
, "tips" .= oT
|
||||
]
|
||||
where
|
||||
keyObfuscate s
|
||||
|
@ -392,6 +414,7 @@ getOwnerSettings o =
|
|||
(opayconf o)
|
||||
(ocrmToken o)
|
||||
(oviewkey o)
|
||||
(otips o)
|
||||
|
||||
-- Database actions
|
||||
-- | Function to upsert an Owner
|
||||
|
@ -424,6 +447,10 @@ findExpiringOwners now =
|
|||
["paid" =: True, "expiration" =: ["$lte" =: addUTCTime 172800 now]]
|
||||
"owners")
|
||||
|
||||
findWithKeys :: Action IO [Document]
|
||||
findWithKeys =
|
||||
rest =<< find (select ["paid" =: True, "payconf" =: True] "owners")
|
||||
|
||||
removePro :: T.Text -> Action IO ()
|
||||
removePro o =
|
||||
modify (select ["address" =: o] "owners") ["$set" =: ["invoices" =: False]]
|
||||
|
@ -442,6 +469,7 @@ updateOwnerSettings os =
|
|||
, "zats" =: os_zats os
|
||||
, "payconf" =: os_payconf os
|
||||
, "crmToken" =: os_crmToken os
|
||||
, "tips" =: os_tips os
|
||||
]
|
||||
]
|
||||
|
||||
|
@ -450,14 +478,12 @@ upsertViewingKey o vk =
|
|||
modify (select ["_id" =: o_id o] "owners") ["$set" =: ["viewKey" =: vk]]
|
||||
|
||||
-- | Type for a pro session
|
||||
data ZGoProSession =
|
||||
ZGoProSession
|
||||
{ ps_id :: Maybe ObjectId
|
||||
, psaddress :: T.Text
|
||||
, psexpiration :: UTCTime
|
||||
, psclosed :: Bool
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
data ZGoProSession = ZGoProSession
|
||||
{ ps_id :: Maybe ObjectId
|
||||
, psaddress :: T.Text
|
||||
, psexpiration :: UTCTime
|
||||
, psclosed :: Bool
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance Val ZGoProSession where
|
||||
cast' (Doc d) = do
|
||||
|
|
|
@ -25,7 +25,7 @@ import Data.Char
|
|||
import qualified Data.HashMap.Strict as HM
|
||||
import Data.HexString
|
||||
import Data.Maybe
|
||||
import qualified Data.Scientific as Scientific
|
||||
import qualified Data.Scientific as SC
|
||||
import Data.SecureMem
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
|
@ -37,9 +37,8 @@ import Data.Time.Format
|
|||
import Data.Typeable
|
||||
import qualified Data.UUID as U
|
||||
import qualified Data.Vector as V
|
||||
import Data.Vector.Internal.Check (doChecks)
|
||||
import Data.Word
|
||||
import Database.MongoDB hiding (Order)
|
||||
import Database.MongoDB hiding (Order, lookup)
|
||||
import Debug.Trace
|
||||
import GHC.Generics
|
||||
import Item
|
||||
|
@ -53,6 +52,7 @@ import Numeric
|
|||
import Order
|
||||
import Owner
|
||||
import Payment
|
||||
import System.IO
|
||||
import System.IO.Unsafe
|
||||
import System.Random
|
||||
import Test.QuickCheck
|
||||
|
@ -66,88 +66,50 @@ import Web.Scotty
|
|||
import WooCommerce
|
||||
import Xero
|
||||
import ZGoTx
|
||||
import ZcashHaskell.Orchard
|
||||
import ZcashHaskell.Sapling
|
||||
import ZcashHaskell.Types (RawData(..))
|
||||
import ZcashHaskell.Utils (decodeBech32)
|
||||
import ZcashHaskell.Types
|
||||
( BlockResponse(..)
|
||||
, DecodedNote(..)
|
||||
, RawData(..)
|
||||
, RawTxResponse(..)
|
||||
, RpcCall(..)
|
||||
, RpcError(..)
|
||||
, RpcResponse(..)
|
||||
, UnifiedFullViewingKey(..)
|
||||
)
|
||||
import ZcashHaskell.Utils (decodeBech32, makeZcashCall)
|
||||
|
||||
-- Models for API objects
|
||||
-- | A type to model Zcash RPC calls
|
||||
data RpcCall =
|
||||
RpcCall
|
||||
{ jsonrpc :: T.Text
|
||||
, callId :: T.Text
|
||||
, method :: T.Text
|
||||
, parameters :: [Data.Aeson.Value]
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance ToJSON RpcCall where
|
||||
toJSON (RpcCall j c m p) =
|
||||
object ["jsonrpc" .= j, "id" .= c, "method" .= m, "params" .= p]
|
||||
|
||||
-- | A type to model the response of the Zcash RPC
|
||||
data RpcResponse r =
|
||||
MakeRpcResponse
|
||||
{ err :: Maybe RpcError
|
||||
, respId :: T.Text
|
||||
, result :: Maybe r
|
||||
}
|
||||
deriving (Show, Generic, ToJSON)
|
||||
|
||||
instance (FromJSON r) => FromJSON (RpcResponse r) where
|
||||
parseJSON (Object obj) =
|
||||
MakeRpcResponse <$> obj .: "error" <*> obj .: "id" <*> obj .: "result"
|
||||
parseJSON _ = mzero
|
||||
|
||||
data RpcError =
|
||||
RpcError
|
||||
{ ecode :: Double
|
||||
, emessage :: T.Text
|
||||
}
|
||||
deriving (Show, Generic, ToJSON)
|
||||
|
||||
instance FromJSON RpcError where
|
||||
parseJSON =
|
||||
withObject "RpcError" $ \obj -> do
|
||||
c <- obj .: "code"
|
||||
m <- obj .: "message"
|
||||
pure $ RpcError c m
|
||||
|
||||
data Payload r =
|
||||
Payload
|
||||
{ payload :: r
|
||||
}
|
||||
deriving (Show, Generic, ToJSON)
|
||||
data Payload r = Payload
|
||||
{ payload :: r
|
||||
} deriving (Show, Generic, ToJSON)
|
||||
|
||||
instance (FromJSON r) => FromJSON (Payload r) where
|
||||
parseJSON (Object obj) = Payload <$> obj .: "payload"
|
||||
parseJSON _ = mzero
|
||||
|
||||
-- | Type to model a (simplified) block of Zcash blockchain
|
||||
data Block =
|
||||
Block
|
||||
{ height :: Integer
|
||||
, size :: Integer
|
||||
}
|
||||
deriving (Show, Generic, ToJSON)
|
||||
data Block = Block
|
||||
{ height :: Integer
|
||||
, size :: Integer
|
||||
} deriving (Show, Generic, ToJSON)
|
||||
|
||||
instance FromJSON Block where
|
||||
parseJSON (Object obj) = Block <$> obj .: "height" <*> obj .: "size"
|
||||
parseJSON _ = mzero
|
||||
|
||||
-- | 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
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
data ZcashTx = ZcashTx
|
||||
{ ztxid :: T.Text
|
||||
, zamount :: Double
|
||||
, zamountZat :: Integer
|
||||
, zblockheight :: Integer
|
||||
, zblocktime :: Integer
|
||||
, zchange :: Bool
|
||||
, zconfirmations :: Integer
|
||||
, zmemo :: T.Text
|
||||
} deriving (Show, Generic)
|
||||
|
||||
instance FromJSON ZcashTx where
|
||||
parseJSON =
|
||||
|
@ -196,14 +158,12 @@ instance Arbitrary ZcashTx where
|
|||
ZcashTx 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]
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
data AddressGroup = AddressGroup
|
||||
{ agsource :: AddressSource
|
||||
, agtransparent :: [ZcashAddress]
|
||||
, agsapling :: [ZcashAddress]
|
||||
, agunified :: [ZcashAddress]
|
||||
} deriving (Show, Generic)
|
||||
|
||||
instance FromJSON AddressGroup where
|
||||
parseJSON =
|
||||
|
@ -284,14 +244,12 @@ instance FromJSON ZcashPool where
|
|||
"orchard" -> return Orchard
|
||||
_ -> fail "Not a known Zcash pool"
|
||||
|
||||
data ZcashAddress =
|
||||
ZcashAddress
|
||||
{ source :: AddressSource
|
||||
, pool :: [ZcashPool]
|
||||
, account :: Maybe Integer
|
||||
, addy :: T.Text
|
||||
}
|
||||
deriving (Eq)
|
||||
data ZcashAddress = ZcashAddress
|
||||
{ source :: AddressSource
|
||||
, pool :: [ZcashPool]
|
||||
, account :: Maybe Integer
|
||||
, addy :: T.Text
|
||||
} deriving (Eq)
|
||||
|
||||
instance Show ZcashAddress where
|
||||
show (ZcashAddress s p i a) =
|
||||
|
@ -315,13 +273,11 @@ encodeHexText t = T.unpack . toText . fromBytes $ 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
|
||||
}
|
||||
deriving (Eq, Show, Generic, ToJSON)
|
||||
data Country = Country
|
||||
{ _id :: String
|
||||
, name :: T.Text
|
||||
, code :: T.Text
|
||||
} deriving (Eq, Show, Generic, ToJSON)
|
||||
|
||||
parseCountryBson :: B.Document -> Maybe Country
|
||||
parseCountryBson d = do
|
||||
|
@ -364,10 +320,11 @@ zToZGoTx (ZcashTx t a aZ bh bt c conf m) = do
|
|||
|
||||
zToZGoTx' :: Config -> Pipe -> ZcashTx -> IO ()
|
||||
zToZGoTx' config pipe (ZcashTx t a aZ bh bt c conf m) = do
|
||||
when (conf < 100) $ do
|
||||
when (conf < c_confirmations config) $ do
|
||||
let zM = runParser pZGoMemo (T.unpack t) m
|
||||
case zM of
|
||||
Right zM' -> do
|
||||
print zM'
|
||||
let tx =
|
||||
ZGoTx
|
||||
Nothing
|
||||
|
@ -384,14 +341,12 @@ zToZGoTx' config pipe (ZcashTx t a aZ bh bt c conf m) = do
|
|||
Left e -> print $ "Failed to parse ZGo memo: " ++ show e
|
||||
|
||||
-- |Type to model a price in the ZGo database
|
||||
data ZGoPrice =
|
||||
ZGoPrice
|
||||
{ _id :: String
|
||||
, currency :: T.Text
|
||||
, price :: Double
|
||||
, timestamp :: UTCTime
|
||||
}
|
||||
deriving (Eq, Show, Generic, ToJSON)
|
||||
data ZGoPrice = ZGoPrice
|
||||
{ _id :: String
|
||||
, currency :: T.Text
|
||||
, price :: Double
|
||||
, timestamp :: UTCTime
|
||||
} deriving (Eq, Show, Generic, ToJSON)
|
||||
|
||||
parseZGoPrice :: B.Document -> Maybe ZGoPrice
|
||||
parseZGoPrice d = do
|
||||
|
@ -418,12 +373,7 @@ listCountries :: Action IO [Document]
|
|||
listCountries = rest =<< find (select [] "countries")
|
||||
|
||||
sendPin ::
|
||||
BS.ByteString
|
||||
-> BS.ByteString
|
||||
-> T.Text
|
||||
-> T.Text
|
||||
-> T.Text
|
||||
-> Action IO String
|
||||
BS.ByteString -> BS.ByteString -> T.Text -> T.Text -> T.Text -> IO String
|
||||
sendPin nodeUser nodePwd nodeAddress addr pin = do
|
||||
let pd =
|
||||
[ Data.Aeson.String nodeAddress
|
||||
|
@ -435,17 +385,73 @@ sendPin nodeUser nodePwd nodeAddress addr pin = do
|
|||
, "memo" .= encodeHexText ("ZGo PIN: " <> pin)
|
||||
]
|
||||
])
|
||||
, Data.Aeson.Number $ SC.scientific 1 1
|
||||
, Data.Aeson.Null
|
||||
, Data.Aeson.String "AllowRevealedAmounts"
|
||||
]
|
||||
r <- liftIO $ try $ makeZcashCall nodeUser nodePwd "z_sendmany" pd -- IO (Either HttpException (Response Object))
|
||||
r <- liftIO $ try $ makeZcashCall nodeUser nodePwd "z_sendmany" pd
|
||||
case r of
|
||||
Right res -> do
|
||||
let sCode = getResponseStatus (res :: Response Object)
|
||||
let sCode = getResponseStatus (res :: Response (RpcResponse T.Text))
|
||||
let rBody = getResponseBody res
|
||||
if sCode == ok200
|
||||
then return "Pin sent!"
|
||||
then do
|
||||
case result rBody of
|
||||
Nothing -> return "Couldn't parse node response"
|
||||
Just x -> do
|
||||
putStr " Sending."
|
||||
checkOpResult nodeUser nodePwd x
|
||||
return "Pin sent!"
|
||||
else return "Pin sending failed :("
|
||||
Left ex ->
|
||||
return $ "Failed to send tx to node :(" ++ show (ex :: HttpException)
|
||||
|
||||
-- | Type for Operation Result
|
||||
data OpResult = OpResult
|
||||
{ opsuccess :: T.Text
|
||||
, opmessage :: Maybe T.Text
|
||||
, optxid :: Maybe T.Text
|
||||
} deriving (Show, Eq)
|
||||
|
||||
instance FromJSON OpResult where
|
||||
parseJSON =
|
||||
withObject "OpResult" $ \obj -> do
|
||||
s <- obj .: "status"
|
||||
r <- obj .:? "result"
|
||||
e <- obj .:? "error"
|
||||
t <-
|
||||
case r of
|
||||
Nothing -> return Nothing
|
||||
Just r' -> r' .: "txid"
|
||||
m <-
|
||||
case e of
|
||||
Nothing -> return Nothing
|
||||
Just m' -> m' .: "message"
|
||||
pure $ OpResult s m t
|
||||
|
||||
checkOpResult :: BS.ByteString -> BS.ByteString -> T.Text -> IO ()
|
||||
checkOpResult user pwd opid = do
|
||||
response <-
|
||||
makeZcashCall
|
||||
user
|
||||
pwd
|
||||
"z_getoperationstatus"
|
||||
[Data.Aeson.Array (V.fromList [Data.Aeson.String opid])]
|
||||
let rpcResp = getResponseBody response :: (RpcResponse [OpResult])
|
||||
case result rpcResp of
|
||||
Nothing -> putStrLn "Couldn't read response from node"
|
||||
Just opCode -> mapM_ showResult opCode
|
||||
where
|
||||
showResult t =
|
||||
case opsuccess t of
|
||||
"success" ->
|
||||
putStrLn $ " Success! Tx ID: " ++ maybe "" T.unpack (optxid t)
|
||||
"executing" -> do
|
||||
putStr "."
|
||||
hFlush stdout
|
||||
threadDelay 1000000 >> checkOpResult user pwd opid
|
||||
_ -> putStrLn $ " Failed :( " ++ maybe "" T.unpack (opmessage t)
|
||||
|
||||
-- | Function to create user from ZGoTx
|
||||
addUser ::
|
||||
BS.ByteString
|
||||
|
@ -460,7 +466,7 @@ addUser nodeUser nodePwd p db node (Just tx) = do
|
|||
isNew <- liftIO $ isUserNew p db tx
|
||||
when isNew $ do
|
||||
newPin <- liftIO generatePin
|
||||
_ <- sendPin nodeUser nodePwd node (address tx) (T.pack newPin)
|
||||
_ <- liftIO $ sendPin nodeUser nodePwd node (address tx) (T.pack newPin)
|
||||
let pinHash =
|
||||
BLK.hash
|
||||
[ BA.pack . BS.unpack . C.pack . T.unpack $
|
||||
|
@ -584,6 +590,7 @@ routes pipe config = do
|
|||
let nodeUser = c_nodeUser config
|
||||
let nodePwd = c_nodePwd config
|
||||
let nodeAddress = c_nodeAddress config
|
||||
let dbName = c_dbName config
|
||||
middleware $
|
||||
cors $
|
||||
const $
|
||||
|
@ -717,9 +724,11 @@ routes pipe config = do
|
|||
[ "reportType" .=
|
||||
(7 :: Integer)
|
||||
, "order" .=
|
||||
(Nothing :: Maybe ZGoOrder)
|
||||
(Nothing :: Maybe
|
||||
ZGoOrder)
|
||||
, "shop" .=
|
||||
(Nothing :: Maybe String)
|
||||
(Nothing :: Maybe
|
||||
String)
|
||||
])
|
||||
Just cp -> do
|
||||
let newOrder =
|
||||
|
@ -752,10 +761,13 @@ routes pipe config = do
|
|||
(xr_shortCode
|
||||
invReq)
|
||||
(T.pack tk)
|
||||
0
|
||||
0
|
||||
0
|
||||
_ <-
|
||||
liftAndCatchIO $
|
||||
run $
|
||||
upsertOrder newOrder
|
||||
upsertOrder newOrder 0 0
|
||||
finalOrder <-
|
||||
liftAndCatchIO $
|
||||
run $
|
||||
|
@ -789,7 +801,8 @@ routes pipe config = do
|
|||
[ "reportType" .=
|
||||
(8 :: Integer)
|
||||
, "order" .=
|
||||
(Nothing :: Maybe ZGoOrder)
|
||||
(Nothing :: Maybe
|
||||
ZGoOrder)
|
||||
, "shop" .=
|
||||
(Nothing :: Maybe String)
|
||||
])
|
||||
|
@ -959,7 +972,8 @@ 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.DEFAULT_DIGEST_LEN)
|
||||
(BLK.hash [BA.pack . BS.unpack . C.pack $ s :: BA.Bytes] :: BLK.Digest
|
||||
BLK.DEFAULT_DIGEST_LEN)
|
||||
get "/woopayment" $ do
|
||||
oid <- param "ownerid"
|
||||
t <- param "token"
|
||||
|
@ -1029,6 +1043,9 @@ routes pipe config = do
|
|||
[T.pack sUrl, "-", ordId, "-", orderKey])
|
||||
""
|
||||
(T.pack tk)
|
||||
0
|
||||
0
|
||||
0
|
||||
newId <- liftAndCatchIO $ run (insertWooOrder newOrder)
|
||||
status ok200
|
||||
Web.Scotty.json
|
||||
|
@ -1190,6 +1207,7 @@ routes pipe config = do
|
|||
False
|
||||
""
|
||||
""
|
||||
False
|
||||
status accepted202
|
||||
post "/api/ownersettings" $ do
|
||||
s <- param "session"
|
||||
|
@ -1218,37 +1236,56 @@ routes pipe config = do
|
|||
case cast' . Doc =<< u of
|
||||
Nothing -> status unauthorized401
|
||||
Just u' -> do
|
||||
if isValidSaplingViewingKey qBytes
|
||||
then if matchSaplingAddress
|
||||
qBytes
|
||||
(bytes . decodeBech32 . C.pack . T.unpack $ uaddress u')
|
||||
then do
|
||||
owner <- liftAndCatchIO $ run (findOwner $ uaddress u')
|
||||
case cast' . Doc =<< owner of
|
||||
Nothing -> status badRequest400
|
||||
Just o' -> do
|
||||
unless (oviewkey o' /= "") $ do
|
||||
vkInfo <-
|
||||
liftAndCatchIO $
|
||||
makeZcashCall
|
||||
nodeUser
|
||||
nodePwd
|
||||
"z_importviewingkey"
|
||||
[ Data.Aeson.String (T.strip . T.pack $ q)
|
||||
, "no"
|
||||
]
|
||||
let content =
|
||||
getResponseBody vkInfo :: RpcResponse Object
|
||||
if isNothing (err content)
|
||||
then do
|
||||
_ <-
|
||||
liftAndCatchIO $ run (upsertViewingKey o' q)
|
||||
status created201
|
||||
else do
|
||||
text $ L.pack . show $ err content
|
||||
status badRequest400
|
||||
else status forbidden403
|
||||
else status badRequest400
|
||||
if isValidSaplingViewingKey $ C.pack q
|
||||
then do
|
||||
if matchSaplingAddress
|
||||
qBytes
|
||||
(bytes . decodeBech32 . C.pack . T.unpack $ uaddress u')
|
||||
then do
|
||||
owner <- liftAndCatchIO $ run (findOwner $ uaddress u')
|
||||
case cast' . Doc =<< owner of
|
||||
Nothing -> status badRequest400
|
||||
Just o' -> do
|
||||
unless (oviewkey o' /= "") $ do
|
||||
liftAndCatchIO $ run (upsertViewingKey o' q)
|
||||
status created201
|
||||
else status forbidden403
|
||||
else case decodeUfvk (C.pack q) of
|
||||
Nothing -> status badRequest400
|
||||
Just fvk -> do
|
||||
case isValidUnifiedAddress $
|
||||
C.pack . T.unpack $ uaddress u' of
|
||||
Just uaok -> do
|
||||
if matchOrchardAddress
|
||||
(C.pack q)
|
||||
(C.pack . T.unpack $ uaddress u')
|
||||
then do
|
||||
owner <-
|
||||
liftAndCatchIO $ run (findOwner $ uaddress u')
|
||||
case cast' . Doc =<< owner of
|
||||
Nothing -> status badRequest400
|
||||
Just o' -> do
|
||||
unless (oviewkey o' /= "") $ do
|
||||
liftAndCatchIO $
|
||||
run (upsertViewingKey o' q)
|
||||
status created201
|
||||
else status forbidden403
|
||||
Nothing -> do
|
||||
if matchSaplingAddress
|
||||
(s_key fvk)
|
||||
(bytes . decodeBech32 . C.pack . T.unpack $
|
||||
uaddress u')
|
||||
then do
|
||||
owner <-
|
||||
liftAndCatchIO $ run (findOwner $ uaddress u')
|
||||
case cast' . Doc =<< owner of
|
||||
Nothing -> status badRequest400
|
||||
Just o' -> do
|
||||
unless (oviewkey o' /= "") $ do
|
||||
liftAndCatchIO $
|
||||
run (upsertViewingKey o' q)
|
||||
status created201
|
||||
else status forbidden403
|
||||
--Get items associated with the given address
|
||||
get "/api/items" $ do
|
||||
session <- param "session"
|
||||
|
@ -1302,15 +1339,12 @@ routes pipe config = do
|
|||
get "/price" $ do
|
||||
curr <- param "currency"
|
||||
pr <- liftAndCatchIO $ run (findPrice curr)
|
||||
case pr of
|
||||
case parseZGoPrice =<< pr of
|
||||
Nothing -> do
|
||||
status noContent204
|
||||
Just p -> do
|
||||
Web.Scotty.json
|
||||
(object
|
||||
[ "message" .= ("Price found!" :: String)
|
||||
, "price" .= toJSON (parseZGoPrice p)
|
||||
])
|
||||
(object ["message" .= ("Price found!" :: String), "price" .= toJSON p])
|
||||
--Get all closed orders for the address
|
||||
get "/api/allorders" $ do
|
||||
session <- param "session"
|
||||
|
@ -1373,26 +1407,26 @@ routes pipe config = do
|
|||
, "order" .= toJSON (pOrder :: ZGoOrder)
|
||||
])
|
||||
--Upsert xero order
|
||||
post "/api/orderx" $ do
|
||||
newOrder <- jsonData
|
||||
let q = payload (newOrder :: Payload ZGoOrder)
|
||||
_ <- liftIO $ run (upsertXeroOrder q)
|
||||
myOrder <-
|
||||
liftAndCatchIO $
|
||||
run (findXeroOrder (qaddress q) (qexternalInvoice q) (qshortCode q))
|
||||
case myOrder of
|
||||
Nothing -> status noContent204
|
||||
Just o -> do
|
||||
let o' = cast' (Doc o)
|
||||
case o' of
|
||||
Nothing -> status internalServerError500
|
||||
Just pOrder -> do
|
||||
status created201
|
||||
Web.Scotty.json
|
||||
(object
|
||||
[ "message" .= ("Order found!" :: String)
|
||||
, "order" .= toJSON (pOrder :: ZGoOrder)
|
||||
])
|
||||
{-post "/api/orderx" $ do-}
|
||||
{-newOrder <- jsonData-}
|
||||
{-let q = payload (newOrder :: Payload ZGoOrder)-}
|
||||
{-_ <- liftIO $ run (upsertXeroOrder q)-}
|
||||
{-myOrder <--}
|
||||
{-liftAndCatchIO $-}
|
||||
{-run (findXeroOrder (qaddress q) (qexternalInvoice q) (qshortCode q))-}
|
||||
{-case myOrder of-}
|
||||
{-Nothing -> status noContent204-}
|
||||
{-Just o -> do-}
|
||||
{-let o' = cast' (Doc o)-}
|
||||
{-case o' of-}
|
||||
{-Nothing -> status internalServerError500-}
|
||||
{-Just pOrder -> do-}
|
||||
{-status created201-}
|
||||
{-Web.Scotty.json-}
|
||||
{-(object-}
|
||||
{-[ "message" .= ("Order found!" :: String)-}
|
||||
{-, "order" .= toJSON (pOrder :: ZGoOrder)-}
|
||||
{-])-}
|
||||
-- Upsert order
|
||||
post "/api/order" $ do
|
||||
newOrder <- jsonData
|
||||
|
@ -1402,20 +1436,73 @@ routes pipe config = do
|
|||
case cast' . Doc =<< user of
|
||||
Nothing -> status unauthorized401
|
||||
Just u -> do
|
||||
if uaddress u == qaddress q
|
||||
then do
|
||||
if qtoken q == ""
|
||||
then do
|
||||
t <- liftIO generateToken
|
||||
_ <-
|
||||
liftAndCatchIO $
|
||||
run (upsertOrder $ setOrderToken (T.pack t) q)
|
||||
status created201
|
||||
else do
|
||||
_ <- liftAndCatchIO $ run (upsertOrder q)
|
||||
status created201
|
||||
else status forbidden403
|
||||
--Delete order
|
||||
owner <- liftAndCatchIO $ run $ findOwner (uaddress u)
|
||||
case cast' . Doc =<< owner of
|
||||
Nothing -> status badRequest400
|
||||
Just o -> do
|
||||
let taxRate =
|
||||
if otax o
|
||||
then otaxValue o
|
||||
else 0
|
||||
let vatRate =
|
||||
if ovat o
|
||||
then ovatValue o
|
||||
else 0
|
||||
dbOrder <-
|
||||
liftAndCatchIO $ run (findOrderById $ maybe "0" show (q_id q))
|
||||
case cast' . Doc =<< dbOrder of
|
||||
Nothing -> do
|
||||
if uaddress u == qaddress q
|
||||
then do
|
||||
if qtoken q == ""
|
||||
then do
|
||||
t <- liftIO generateToken
|
||||
_ <-
|
||||
liftAndCatchIO $
|
||||
run
|
||||
(upsertOrder
|
||||
(setOrderToken (T.pack t) q)
|
||||
taxRate
|
||||
vatRate)
|
||||
status created201
|
||||
else do
|
||||
_ <-
|
||||
liftAndCatchIO $
|
||||
access
|
||||
pipe
|
||||
master
|
||||
dbName
|
||||
(upsertOrder q taxRate vatRate)
|
||||
status created201
|
||||
else status forbidden403
|
||||
Just dbO -> do
|
||||
if qaddress q == qaddress dbO && qsession q == qsession dbO
|
||||
then do
|
||||
if uaddress u == qaddress q
|
||||
then do
|
||||
if qtoken q == ""
|
||||
then do
|
||||
t <- liftIO generateToken
|
||||
_ <-
|
||||
liftAndCatchIO $
|
||||
run
|
||||
(upsertOrder
|
||||
(setOrderToken (T.pack t) q)
|
||||
taxRate
|
||||
vatRate)
|
||||
status created201
|
||||
else do
|
||||
_ <-
|
||||
liftAndCatchIO $
|
||||
access
|
||||
pipe
|
||||
master
|
||||
dbName
|
||||
(upsertOrder q taxRate vatRate)
|
||||
status created201
|
||||
else status forbidden403
|
||||
else status forbidden403
|
||||
--Delete order
|
||||
Web.Scotty.delete "/api/order/:id" $ do
|
||||
oId <- param "id"
|
||||
session <- param "session"
|
||||
|
@ -1485,25 +1572,24 @@ routes pipe config = do
|
|||
{-liftAndCatchIO $-}
|
||||
{-mapM (run . loadLangComponent) (langComp :: [LangComponent])-}
|
||||
{-status created201-}
|
||||
{-(MonadIO m, FromJSON a)-}
|
||||
{-=> BS.ByteString-}
|
||||
{--> BS.ByteString-}
|
||||
{--> T.Text-}
|
||||
{--> [Data.Aeson.Value]-}
|
||||
{--> m (Response a)-}
|
||||
{-let payload =-}
|
||||
{-RpcCall {jsonrpc = "1.0", callId = "test", method = m, parameters = p}-}
|
||||
{-let myRequest =-}
|
||||
{-setRequestBodyJSON payload $-}
|
||||
{-setRequestPort 8232 $-}
|
||||
{-setRequestBasicAuth username password $-}
|
||||
{-setRequestMethod "POST" defaultRequest-}
|
||||
{-httpJSON myRequest-}
|
||||
|
||||
-- | Make a Zcash RPC call
|
||||
makeZcashCall ::
|
||||
(MonadIO m, FromJSON a)
|
||||
=> BS.ByteString
|
||||
-> BS.ByteString
|
||||
-> T.Text
|
||||
-> [Data.Aeson.Value]
|
||||
-> m (Response a)
|
||||
makeZcashCall username password m p = do
|
||||
let payload =
|
||||
RpcCall {jsonrpc = "1.0", callId = "test", method = m, parameters = p}
|
||||
let myRequest =
|
||||
setRequestBodyJSON payload $
|
||||
setRequestPort 8232 $
|
||||
setRequestBasicAuth username password $
|
||||
setRequestMethod "POST" defaultRequest
|
||||
httpJSON myRequest
|
||||
|
||||
{-makeZcashCall ::-}
|
||||
{-makeZcashCall username password m p = do-}
|
||||
-- |Timer for repeating actions
|
||||
setInterval :: Int -> IO () -> IO ()
|
||||
setInterval secs func = do
|
||||
|
@ -1545,7 +1631,8 @@ listTxs user pwd a confs = do
|
|||
user
|
||||
pwd
|
||||
"z_listreceivedbyaddress"
|
||||
[Data.Aeson.String a, Data.Aeson.Number $ Scientific.scientific confs 0] :: IO (Either HttpException (Response (RpcResponse [ZcashTx])))
|
||||
[Data.Aeson.String a, Data.Aeson.Number $ SC.scientific confs 0] :: IO
|
||||
(Either HttpException (Response (RpcResponse [ZcashTx])))
|
||||
case res of
|
||||
Right txList -> do
|
||||
let content = getResponseBody txList :: RpcResponse [ZcashTx]
|
||||
|
@ -1678,7 +1765,8 @@ scanPayments config pipe = do
|
|||
listAddresses :: BS.ByteString -> BS.ByteString -> IO [ZcashAddress]
|
||||
listAddresses user pwd = do
|
||||
response <-
|
||||
try $ makeZcashCall user pwd "listaddresses" [] :: IO (Either HttpException (Response (RpcResponse [AddressGroup])))
|
||||
try $ makeZcashCall user pwd "listaddresses" [] :: IO
|
||||
(Either HttpException (Response (RpcResponse [AddressGroup])))
|
||||
case response of
|
||||
Right addrList -> do
|
||||
let rpcResp = getResponseBody addrList
|
||||
|
@ -1741,7 +1829,7 @@ payOwner p d x =
|
|||
markOwnerPaid :: Pipe -> T.Text -> Payment -> IO ()
|
||||
markOwnerPaid pipe db pmt = do
|
||||
user <- access pipe master db (findUser $ psession pmt)
|
||||
print pmt
|
||||
-- print pmt
|
||||
let parsedUser = parseUserBson =<< user
|
||||
let zaddy = maybe "" uaddress parsedUser
|
||||
owner <- access pipe master db $ findOwner zaddy
|
||||
|
@ -1847,4 +1935,263 @@ generateToken = do
|
|||
rngState <- newCryptoRNGState
|
||||
runCryptoRNGT rngState $ randomString 24 "abcdef0123456789"
|
||||
|
||||
getBlockInfo ::
|
||||
BS.ByteString -> BS.ByteString -> T.Text -> IO (Maybe BlockResponse)
|
||||
getBlockInfo nodeUser nodePwd bh = do
|
||||
blockInfo <-
|
||||
makeZcashCall
|
||||
nodeUser
|
||||
nodePwd
|
||||
"getblock"
|
||||
[Data.Aeson.String bh, Number $ SC.scientific 1 0]
|
||||
let content = getResponseBody blockInfo :: RpcResponse BlockResponse
|
||||
if isNothing (err content)
|
||||
then return $ result content
|
||||
else do
|
||||
print $ err content
|
||||
return Nothing
|
||||
|
||||
scanTxNative :: Config -> Pipe -> IO ()
|
||||
scanTxNative config pipe = do
|
||||
let db = c_dbName config
|
||||
keyOwnerList <- access pipe master db findWithKeys
|
||||
unless (null keyOwnerList) $ do
|
||||
let nodeUser = c_nodeUser config
|
||||
let nodePwd = c_nodePwd config
|
||||
let ownerList = mapMaybe (cast' . Doc) keyOwnerList
|
||||
lastBlockData <- access pipe master db findBlock
|
||||
latestBlock <- getBlockInfo nodeUser nodePwd "-1"
|
||||
case latestBlock of
|
||||
Nothing -> fail "No block data from node"
|
||||
Just lB -> do
|
||||
case cast' . Doc =<< lastBlockData of
|
||||
Nothing -> do
|
||||
print "Getting blocks"
|
||||
blockList <-
|
||||
mapM
|
||||
(getBlockInfo nodeUser nodePwd . T.pack . show)
|
||||
[(bl_height lB - 50) .. (bl_height lB)]
|
||||
print "filtering blocks..."
|
||||
let filteredBlockList = filter filterBlock blockList
|
||||
print "extracting txs from blocks..."
|
||||
let txIdList = concatMap extractTxs filteredBlockList
|
||||
print "getting tx data from node..."
|
||||
txList <- mapM (getTxData nodeUser nodePwd) txIdList
|
||||
print "filtering txs..."
|
||||
let filteredTxList = map fromJust $ filter filterTx txList
|
||||
print "checking txs against keys..."
|
||||
mapM_ (checkTx filteredTxList) ownerList
|
||||
access pipe master (c_dbName config) $
|
||||
upsertBlock (last $ catMaybes filteredBlockList)
|
||||
Just lastBlock -> do
|
||||
blockList' <-
|
||||
mapM
|
||||
(getBlockInfo nodeUser nodePwd . T.pack . show)
|
||||
[(bl_height lastBlock + 1) .. (bl_height lB)]
|
||||
print "filtering blocks..."
|
||||
let filteredBlockList = filter filterBlock blockList'
|
||||
print "extracting txs from blocks..."
|
||||
let txIdList = concatMap extractTxs filteredBlockList
|
||||
print "getting tx data from node..."
|
||||
txList <- mapM (getTxData nodeUser nodePwd) txIdList
|
||||
print "filtering txs..."
|
||||
let filteredTxList = map fromJust $ filter filterTx txList
|
||||
print "checking txs against keys..."
|
||||
mapM_ (checkTx filteredTxList) ownerList
|
||||
access pipe master (c_dbName config) $
|
||||
upsertBlock (last $ catMaybes filteredBlockList)
|
||||
where
|
||||
filterBlock :: Maybe BlockResponse -> Bool
|
||||
filterBlock b = maybe 0 bl_confirmations b >= 5
|
||||
filterTx :: Maybe RawTxResponse -> Bool
|
||||
filterTx t =
|
||||
not (null (maybe [] rt_shieldedOutputs t)) ||
|
||||
not (null (maybe [] rt_orchardActions t))
|
||||
extractTxs :: Maybe BlockResponse -> [T.Text]
|
||||
extractTxs = maybe [] bl_txs
|
||||
getTxData ::
|
||||
BS.ByteString -> BS.ByteString -> T.Text -> IO (Maybe RawTxResponse)
|
||||
getTxData nodeUser nodePwd txid = do
|
||||
txInfo <-
|
||||
makeZcashCall
|
||||
nodeUser
|
||||
nodePwd
|
||||
"getrawtransaction"
|
||||
[Data.Aeson.String txid, Number $ SC.scientific 1 0]
|
||||
let content = getResponseBody txInfo :: RpcResponse RawTxResponse
|
||||
if isNothing (err content)
|
||||
then return $ result content
|
||||
else do
|
||||
print $ err content
|
||||
return Nothing
|
||||
checkTx :: [RawTxResponse] -> Owner -> IO ()
|
||||
checkTx txList' k = do
|
||||
let sOutList = concatMap rt_shieldedOutputs txList'
|
||||
if isValidSaplingViewingKey (E.encodeUtf8 $ oviewkey k)
|
||||
then do
|
||||
print "decoding Sapling tx"
|
||||
let decodedSapList' = concatMap (decodeSaplingTx $ oviewkey k) txList'
|
||||
let zList = catMaybes decodedSapList'
|
||||
mapM_ (recordPayment pipe (c_dbName config) (oaddress k)) zList
|
||||
else do
|
||||
let vk = decodeUfvk $ E.encodeUtf8 $ oviewkey k
|
||||
case vk of
|
||||
Nothing -> print "Not a valid key"
|
||||
Just v -> do
|
||||
let decodedSapList =
|
||||
concatMap (decodeUnifiedSaplingTx (s_key v)) txList'
|
||||
let zList' = catMaybes decodedSapList
|
||||
mapM_ (recordPayment pipe (c_dbName config) (oaddress k)) zList'
|
||||
let decodedOrchList = concatMap (decodeUnifiedOrchardTx v) txList'
|
||||
let oList = catMaybes decodedOrchList
|
||||
mapM_ (recordPayment pipe (c_dbName config) (oaddress k)) oList
|
||||
decodeSaplingTx :: T.Text -> RawTxResponse -> [Maybe ZcashTx]
|
||||
decodeSaplingTx k t =
|
||||
map
|
||||
(buildZcashTx t .
|
||||
decodeSaplingOutput (bytes (decodeBech32 $ E.encodeUtf8 k)))
|
||||
(rt_shieldedOutputs t)
|
||||
decodeUnifiedSaplingTx :: BS.ByteString -> RawTxResponse -> [Maybe ZcashTx]
|
||||
decodeUnifiedSaplingTx k t =
|
||||
map (buildZcashTx t . decodeSaplingOutput k) (rt_shieldedOutputs t)
|
||||
decodeUnifiedOrchardTx ::
|
||||
UnifiedFullViewingKey -> RawTxResponse -> [Maybe ZcashTx]
|
||||
decodeUnifiedOrchardTx k t =
|
||||
map (buildZcashTx t . decryptOrchardAction k) (rt_orchardActions t)
|
||||
buildZcashTx :: RawTxResponse -> Maybe DecodedNote -> Maybe ZcashTx
|
||||
buildZcashTx t n =
|
||||
case n of
|
||||
Nothing -> Nothing
|
||||
Just n ->
|
||||
Just $
|
||||
ZcashTx
|
||||
(rt_id t)
|
||||
(fromIntegral (a_value n) / 100000000)
|
||||
(toInteger $ a_value n)
|
||||
(rt_blockheight t)
|
||||
(rt_blocktime t)
|
||||
False
|
||||
(rt_confirmations t)
|
||||
(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)
|
||||
case zM of
|
||||
Right m -> do
|
||||
case m_orderId m of
|
||||
Nothing -> print "Not an order Tx"
|
||||
Just orderId -> do
|
||||
print orderId
|
||||
o <- access p master dbName $ findOrderById (T.unpack orderId)
|
||||
let xOrder = o >>= (cast' . Doc)
|
||||
case xOrder of
|
||||
Nothing -> error "Failed to retrieve order from database"
|
||||
Just xO -> do
|
||||
when
|
||||
(not (qpaid xO) &&
|
||||
qtotalZec xO == zamount x && z == qaddress xO) $ do
|
||||
let sReg = mkRegex "(.*)-([a-fA-f0-9]{24})"
|
||||
let sResult = matchAllText sReg (T.unpack $ qsession xO)
|
||||
if not (null sResult)
|
||||
then case fst $ head sResult ! 1 of
|
||||
"Xero" -> do
|
||||
xeroConfig <- access p master dbName findXero
|
||||
let xC = xeroConfig >>= (cast' . Doc)
|
||||
case xC of
|
||||
Nothing -> error "Failed to read Xero config"
|
||||
Just xConf -> do
|
||||
requestXeroToken
|
||||
p
|
||||
dbName
|
||||
xConf
|
||||
""
|
||||
(qaddress xO)
|
||||
payXeroInvoice
|
||||
p
|
||||
dbName
|
||||
(qexternalInvoice xO)
|
||||
(qaddress xO)
|
||||
(qtotal xO)
|
||||
(qtotalZec xO)
|
||||
liftIO $
|
||||
access p master dbName $
|
||||
markOrderPaid (T.unpack orderId, zamount x)
|
||||
"WC" -> do
|
||||
let wOwner = fst $ head sResult ! 2
|
||||
wooT <-
|
||||
access p master dbName $
|
||||
findWooToken $ Just (read wOwner)
|
||||
let wT = wooT >>= (cast' . Doc)
|
||||
case wT of
|
||||
Nothing ->
|
||||
error "Failed to read WooCommerce token"
|
||||
Just wt -> do
|
||||
let iReg = mkRegex "(.*)-(.*)-.*"
|
||||
let iResult =
|
||||
matchAllText
|
||||
iReg
|
||||
(T.unpack $ qexternalInvoice xO)
|
||||
if not (null iResult)
|
||||
then do
|
||||
let wUrl =
|
||||
E.decodeUtf8With lenientDecode .
|
||||
B64.decodeLenient . C.pack $
|
||||
fst $ head iResult ! 1
|
||||
let iNum = fst $ head iResult ! 2
|
||||
payWooOrder
|
||||
(T.unpack wUrl)
|
||||
(C.pack iNum)
|
||||
(C.pack $ maybe "" show (q_id xO))
|
||||
(C.pack . T.unpack $ w_token wt)
|
||||
(C.pack . show $ qprice xO)
|
||||
(C.pack . show $ qtotalZec xO)
|
||||
liftIO $
|
||||
access p master dbName $
|
||||
markOrderPaid
|
||||
(T.unpack orderId, zamount x)
|
||||
else error
|
||||
"Couldn't parse externalInvoice for WooCommerce"
|
||||
_ -> putStrLn "Not an integration order"
|
||||
else liftIO $
|
||||
access p master dbName $
|
||||
markOrderPaid (T.unpack orderId, zamount x)
|
||||
Left e -> print "Unable to parse order memo"
|
||||
|
||||
debug = flip trace
|
||||
|
||||
instance Val BlockResponse where
|
||||
cast' (Doc d) = do
|
||||
c <- B.lookup "confirmations" d
|
||||
h <- B.lookup "height" d
|
||||
t <- B.lookup "time" d
|
||||
txs <- B.lookup "tx" d
|
||||
Just (BlockResponse c h t txs)
|
||||
cast' _ = Nothing
|
||||
val (BlockResponse c h t txs) =
|
||||
Doc
|
||||
[ "confirmations" =: c
|
||||
, "height" =: h
|
||||
, "time" =: t
|
||||
, "tx" =: txs
|
||||
, "network" =: ("mainnet" :: String)
|
||||
]
|
||||
|
||||
upsertBlock :: BlockResponse -> Action IO ()
|
||||
upsertBlock b = do
|
||||
let block = val b
|
||||
case block of
|
||||
Doc d -> upsert (select ["network" =: ("mainnet" :: String)] "blocks") d
|
||||
_ -> return ()
|
||||
|
||||
findBlock :: Action IO (Maybe Document)
|
||||
findBlock = findOne (select ["network" =: ("mainnet" :: String)] "blocks")
|
||||
|
||||
loadTranslations :: Pipe -> Config -> IO ()
|
||||
loadTranslations pipe config = do
|
||||
itemList <- decodeFileStrict "zgolanguagedb.json"
|
||||
case itemList of
|
||||
Nothing -> print "Couldn't not parse JSON file"
|
||||
Just langItems ->
|
||||
mapM_
|
||||
(access pipe master (c_dbName config) . loadLangComponent)
|
||||
(langItems :: [LangComponent])
|
||||
|
|
70
src/ZGoTx.hs
70
src/ZGoTx.hs
|
@ -9,26 +9,27 @@ import qualified Data.Bson as B
|
|||
import Data.Char
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified Data.UUID as U
|
||||
import Data.Void
|
||||
import Database.MongoDB
|
||||
import GHC.Generics
|
||||
import Text.Megaparsec hiding (State)
|
||||
import Text.Megaparsec.Char
|
||||
import ZcashHaskell.Orchard
|
||||
import ZcashHaskell.Sapling (isValidShieldedAddress)
|
||||
|
||||
-- | Type to model a ZGo transaction
|
||||
data ZGoTx =
|
||||
ZGoTx
|
||||
{ _id :: Maybe ObjectId
|
||||
, address :: T.Text
|
||||
, session :: T.Text
|
||||
, confirmations :: Integer
|
||||
, blocktime :: Integer
|
||||
, amount :: Double
|
||||
, txid :: T.Text
|
||||
, memo :: T.Text
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
data ZGoTx = ZGoTx
|
||||
{ _id :: Maybe ObjectId
|
||||
, address :: T.Text
|
||||
, session :: T.Text
|
||||
, confirmations :: Integer
|
||||
, blocktime :: Integer
|
||||
, amount :: Double
|
||||
, txid :: T.Text
|
||||
, memo :: T.Text
|
||||
} deriving (Eq, Show, Generic)
|
||||
|
||||
parseZGoTxBson :: B.Document -> Maybe ZGoTx
|
||||
parseZGoTxBson d = do
|
||||
|
@ -100,19 +101,19 @@ instance Val ZGoTx where
|
|||
]
|
||||
|
||||
-- | Type to represent and parse ZGo memos
|
||||
data ZGoMemo =
|
||||
ZGoMemo
|
||||
{ m_session :: Maybe U.UUID
|
||||
, m_address :: Maybe T.Text
|
||||
, m_payment :: Bool
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
data ZGoMemo = ZGoMemo
|
||||
{ m_session :: Maybe U.UUID
|
||||
, m_address :: Maybe T.Text
|
||||
, m_payment :: Bool
|
||||
, m_orderId :: Maybe T.Text
|
||||
} deriving (Eq, Show)
|
||||
|
||||
data MemoToken
|
||||
= Login !U.UUID
|
||||
| PayMsg !U.UUID
|
||||
| Address !T.Text
|
||||
| Msg !T.Text
|
||||
| OrderId !T.Text
|
||||
deriving (Show, Eq)
|
||||
|
||||
type Parser = Parsec Void T.Text
|
||||
|
@ -135,9 +136,23 @@ pSaplingAddress :: Parser MemoToken
|
|||
pSaplingAddress = do
|
||||
string "zs"
|
||||
a <- some alphaNumChar
|
||||
if length a /= 76
|
||||
then fail "Failed to parse Sapling address"
|
||||
else pure $ Address $ T.pack ("zs" <> a)
|
||||
if isValidShieldedAddress (E.encodeUtf8 $ "zs" <> T.pack a)
|
||||
then pure $ Address $ T.pack ("zs" <> a)
|
||||
else fail "Failed to parse Sapling address"
|
||||
|
||||
pUnifiedAddress :: Parser MemoToken
|
||||
pUnifiedAddress = do
|
||||
string "u1"
|
||||
a <- some alphaNumChar
|
||||
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
|
||||
string "ZGo Order::"
|
||||
a <- some hexDigitChar
|
||||
pure $ OrderId . T.pack $ a
|
||||
|
||||
pMsg :: Parser MemoToken
|
||||
pMsg = do
|
||||
|
@ -150,7 +165,7 @@ pMsg = do
|
|||
pMemo :: Parser MemoToken
|
||||
pMemo = do
|
||||
optional $ some spaceChar
|
||||
t <- pSession <|> pSaplingAddress <|> pMsg
|
||||
t <- pSession <|> pSaplingAddress <|> pUnifiedAddress <|> pOrderId <|> pMsg
|
||||
optional $ some spaceChar
|
||||
return t
|
||||
|
||||
|
@ -175,8 +190,15 @@ isMemoToken kind t =
|
|||
pZGoMemo :: Parser ZGoMemo
|
||||
pZGoMemo = do
|
||||
tks <- some pMemo
|
||||
pure $ ZGoMemo (isSession tks) (isAddress tks) (isPayment tks)
|
||||
pure $ ZGoMemo (isSession tks) (isAddress tks) (isPayment tks) (isOrder tks)
|
||||
where
|
||||
isOrder [] = Nothing
|
||||
isOrder tks =
|
||||
if not (null tks)
|
||||
then case head tks of
|
||||
OrderId x -> Just x
|
||||
_ -> isOrder $ tail tks
|
||||
else Nothing
|
||||
isPayment [] = False
|
||||
isPayment tks =
|
||||
not (null tks) &&
|
||||
|
|
11
stack.yaml
11
stack.yaml
|
@ -17,7 +17,7 @@
|
|||
#
|
||||
# resolver: ./custom-snapshot.yaml
|
||||
# resolver: https://example.com/snapshots/2018-01-01.yaml
|
||||
resolver: lts-20.23
|
||||
resolver: lts-21.22
|
||||
#url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/4.yaml
|
||||
|
||||
# User packages to be built.
|
||||
|
@ -42,14 +42,19 @@ 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: fef3d3af35a09db718cddb8fc9166b2d2691a744
|
||||
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
|
||||
|
|
|
@ -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: fef3d3af35a09db718cddb8fc9166b2d2691a744
|
||||
commit: dce171d83043fae0e5c771ff743d31c4ec19c1ae
|
||||
git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git
|
||||
name: zcash-haskell
|
||||
pantry-tree:
|
||||
sha256: ec7782cf2646da17548d59af0ea98dcbaac1b6c2176258c696a7f508db6dbc21
|
||||
size: 1126
|
||||
version: 0.1.0
|
||||
sha256: 000770930e5d50596b82b38984d6e8ab94fd5345c7fcf3cc21682ef8e6348746
|
||||
size: 1365
|
||||
version: 0.3.0
|
||||
original:
|
||||
commit: fef3d3af35a09db718cddb8fc9166b2d2691a744
|
||||
commit: dce171d83043fae0e5c771ff743d31c4ec19c1ae
|
||||
git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git
|
||||
- completed:
|
||||
commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05
|
||||
|
@ -48,6 +48,17 @@ packages:
|
|||
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:
|
||||
|
@ -92,7 +103,7 @@ packages:
|
|||
hackage: crypto-rng-0.3.0.1@sha256:04f4ae75943ecad8b794950985054130f272d65a588b6b6528f56df0bfedc4dc,1565
|
||||
snapshots:
|
||||
- completed:
|
||||
sha256: 4c972e067bae16b95961dbfdd12e07f1ee6c8fffabbfa05c3d65100b03f548b7
|
||||
size: 650253
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/23.yaml
|
||||
original: lts-20.23
|
||||
sha256: afd5ba64ab602cabc2d3942d3d7e7dd6311bc626dcb415b901eaf576cb62f0ea
|
||||
size: 640060
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/22.yaml
|
||||
original: lts-21.22
|
||||
|
|
337
test/Spec.hs
337
test/Spec.hs
|
@ -56,10 +56,10 @@ main = do
|
|||
describe "hex strings" $ do
|
||||
prop "encoding and decoding are inverse" $ \x ->
|
||||
(decodeHexText . encodeHexText) x == x
|
||||
describe "zToZGoTx" $
|
||||
describe "Memo parsers" $
|
||||
--prop "memo parsing" testMemoParser
|
||||
do
|
||||
it "parse ZecWallet memo" $ do
|
||||
it "parse ZecWallet memo - Sapling" $ do
|
||||
let m =
|
||||
runParser
|
||||
pZGoMemo
|
||||
|
@ -70,7 +70,7 @@ main = do
|
|||
Right m' ->
|
||||
m_session m' `shouldBe`
|
||||
U.fromString "5d3d4494-51c0-432d-8495-050419957aea"
|
||||
it "parse YWallet memo" $ do
|
||||
it "parse YWallet memo - Sapling" $ do
|
||||
let m =
|
||||
runParser
|
||||
pZGoMemo
|
||||
|
@ -81,90 +81,53 @@ main = do
|
|||
Right m' ->
|
||||
m_session m' `shouldBe`
|
||||
U.fromString "ad8477d3-4fdd-4c97-90b2-76630b5f77e1"
|
||||
it "converts ZecWallet tx to ZGo tx" $ do
|
||||
let t =
|
||||
ZcashTx
|
||||
"someId"
|
||||
0.5
|
||||
50000000
|
||||
1602000
|
||||
18732456
|
||||
False
|
||||
5
|
||||
"ZGO::5d3d4494-51c0-432d-8495-050419957aea\nReply-To:\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
|
||||
zToZGoTx t `shouldBe`
|
||||
ZGoTx
|
||||
Nothing
|
||||
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
|
||||
"5d3d4494-51c0-432d-8495-050419957aea"
|
||||
5
|
||||
18732456
|
||||
0.5
|
||||
"someId"
|
||||
"ZGO::5d3d4494-51c0-432d-8495-050419957aea\nReply-To:\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
|
||||
it "converts YWallet tx to ZGo tx" $ do
|
||||
let t =
|
||||
ZcashTx
|
||||
"someId"
|
||||
0.5
|
||||
50000000
|
||||
1602000
|
||||
18732456
|
||||
False
|
||||
5
|
||||
"\128737MSG\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e\n\nZGO::ad8477d3-4fdd-4c97-90b2-76630b5f77e1"
|
||||
zToZGoTx t `shouldBe`
|
||||
ZGoTx
|
||||
Nothing
|
||||
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
|
||||
"ad8477d3-4fdd-4c97-90b2-76630b5f77e1"
|
||||
5
|
||||
18732456
|
||||
0.5
|
||||
"someId"
|
||||
"\128737MSG\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e\n\nZGO::ad8477d3-4fdd-4c97-90b2-76630b5f77e1"
|
||||
it "converts ZecWallet payment tx to ZGo tx" $ do
|
||||
let t =
|
||||
ZcashTx
|
||||
"someId"
|
||||
0.5
|
||||
50000000
|
||||
1602000
|
||||
18732456
|
||||
False
|
||||
5
|
||||
"ZGOp::5d3d4494-51c0-432d-8495-050419957aea\nReply-To:\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
|
||||
zToZGoTx t `shouldBe`
|
||||
ZGoTx
|
||||
Nothing
|
||||
""
|
||||
"5d3d4494-51c0-432d-8495-050419957aea"
|
||||
5
|
||||
18732456
|
||||
0.5
|
||||
"someId"
|
||||
"ZGOp::5d3d4494-51c0-432d-8495-050419957aea\nReply-To:\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
|
||||
it "converts YWallet payment tx to ZGo tx" $ do
|
||||
let t =
|
||||
ZcashTx
|
||||
"someId"
|
||||
0.5
|
||||
50000000
|
||||
1602000
|
||||
18732456
|
||||
False
|
||||
5
|
||||
"\128737MSG\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e\n\nZGOp::ad8477d3-4fdd-4c97-90b2-76630b5f77e1"
|
||||
zToZGoTx t `shouldBe`
|
||||
ZGoTx
|
||||
Nothing
|
||||
""
|
||||
"ad8477d3-4fdd-4c97-90b2-76630b5f77e1"
|
||||
5
|
||||
18732456
|
||||
0.5
|
||||
"someId"
|
||||
"\128737MSG\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e\n\nZGOp::ad8477d3-4fdd-4c97-90b2-76630b5f77e1"
|
||||
it "parse Zingo memo - Sapling" $ do
|
||||
let m =
|
||||
runParser
|
||||
pZGoMemo
|
||||
"Zingo memo"
|
||||
"ZGO::5d3d4494-51c0-432d-8495-050419957aea\nReply to:\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
|
||||
case m of
|
||||
Left e -> putStrLn $ errorBundlePretty e
|
||||
Right m' ->
|
||||
m_session m' `shouldBe`
|
||||
U.fromString "5d3d4494-51c0-432d-8495-050419957aea"
|
||||
it "parse ZecWallet memo - Orchard" $ do
|
||||
let m =
|
||||
runParser
|
||||
pZGoMemo
|
||||
"Zecwalllet memo"
|
||||
"ZGO::5d3d4494-51c0-432d-8495-050419957aea\nReply-To:\nu17n7hpwaujyq7ux8f9jpyymtnk5urw7pyrf60smp5mawy7jgz325hfvz3jn3zsfya8yxryf9q7ldk8nu8df0emra5wne28zq9d9nm2pu4x6qwjha565av9aze0xgujgslz74ufkj0c0cylqwjyrh9msjfh7jzal6d3qzrnhkkqy3pqm8j63y07jxj7txqeac982778rmt64f32aum94x"
|
||||
case m of
|
||||
Left e -> putStrLn $ errorBundlePretty e
|
||||
Right m' ->
|
||||
m_address m' `shouldBe`
|
||||
Just
|
||||
"u17n7hpwaujyq7ux8f9jpyymtnk5urw7pyrf60smp5mawy7jgz325hfvz3jn3zsfya8yxryf9q7ldk8nu8df0emra5wne28zq9d9nm2pu4x6qwjha565av9aze0xgujgslz74ufkj0c0cylqwjyrh9msjfh7jzal6d3qzrnhkkqy3pqm8j63y07jxj7txqeac982778rmt64f32aum94x"
|
||||
it "parse YWallet memo - Orchard" $ do
|
||||
let m =
|
||||
runParser
|
||||
pZGoMemo
|
||||
"Ywallet memo"
|
||||
"\128737MSG\nu17n7hpwaujyq7ux8f9jpyymtnk5urw7pyrf60smp5mawy7jgz325hfvz3jn3zsfya8yxryf9q7ldk8nu8df0emra5wne28zq9d9nm2pu4x6qwjha565av9aze0xgujgslz74ufkj0c0cylqwjyrh9msjfh7jzal6d3qzrnhkkqy3pqm8j63y07jxj7txqeac982778rmt64f32aum94x\n\nZGO::ad8477d3-4fdd-4c97-90b2-76630b5f77e1"
|
||||
case m of
|
||||
Left e -> putStrLn $ errorBundlePretty e
|
||||
Right m' ->
|
||||
m_address m' `shouldBe`
|
||||
Just
|
||||
"u17n7hpwaujyq7ux8f9jpyymtnk5urw7pyrf60smp5mawy7jgz325hfvz3jn3zsfya8yxryf9q7ldk8nu8df0emra5wne28zq9d9nm2pu4x6qwjha565av9aze0xgujgslz74ufkj0c0cylqwjyrh9msjfh7jzal6d3qzrnhkkqy3pqm8j63y07jxj7txqeac982778rmt64f32aum94x"
|
||||
it "parse Zingo memo - Orchard" $ do
|
||||
let m =
|
||||
runParser
|
||||
pZGoMemo
|
||||
"Zingo memo"
|
||||
"ZGO::5d3d4494-51c0-432d-8495-050419957aea\nReply to:\nu17n7hpwaujyq7ux8f9jpyymtnk5urw7pyrf60smp5mawy7jgz325hfvz3jn3zsfya8yxryf9q7ldk8nu8df0emra5wne28zq9d9nm2pu4x6qwjha565av9aze0xgujgslz74ufkj0c0cylqwjyrh9msjfh7jzal6d3qzrnhkkqy3pqm8j63y07jxj7txqeac982778rmt64f32aum94x"
|
||||
case m of
|
||||
Left e -> putStrLn $ errorBundlePretty e
|
||||
Right m' ->
|
||||
m_address m' `shouldBe`
|
||||
Just
|
||||
"u17n7hpwaujyq7ux8f9jpyymtnk5urw7pyrf60smp5mawy7jgz325hfvz3jn3zsfya8yxryf9q7ldk8nu8df0emra5wne28zq9d9nm2pu4x6qwjha565av9aze0xgujgslz74ufkj0c0cylqwjyrh9msjfh7jzal6d3qzrnhkkqy3pqm8j63y07jxj7txqeac982778rmt64f32aum94x"
|
||||
describe "PIN generator" $ do
|
||||
it "should give a 7 digit" $ do
|
||||
pin <- generatePin
|
||||
|
@ -335,7 +298,7 @@ main = do
|
|||
it "return owner by id" $ do
|
||||
req <-
|
||||
testGet
|
||||
"/api/ownerid"
|
||||
"/ownerid"
|
||||
[ ("id", Just "627ad3492b05a76be3000001")
|
||||
, ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
|
||||
]
|
||||
|
@ -362,6 +325,9 @@ main = do
|
|||
""
|
||||
""
|
||||
"testToken4321"
|
||||
0
|
||||
0
|
||||
0
|
||||
req <-
|
||||
testPostJson "/api/order" $
|
||||
A.object ["payload" A..= A.toJSON testOrder]
|
||||
|
@ -389,6 +355,9 @@ main = do
|
|||
""
|
||||
""
|
||||
"testToken4321"
|
||||
0
|
||||
0
|
||||
0
|
||||
req <-
|
||||
testPostJson "/api/order" $
|
||||
A.object ["payload" A..= A.toJSON testOrder]
|
||||
|
@ -416,6 +385,9 @@ main = do
|
|||
""
|
||||
""
|
||||
"testToken4321"
|
||||
0
|
||||
0
|
||||
0
|
||||
req <-
|
||||
testPostJson "/api/order" $
|
||||
A.object ["payload" A..= A.toJSON testOrder]
|
||||
|
@ -728,6 +700,8 @@ main = do
|
|||
"zxviews1qdjagrrpqqqqpq8es75mlu6rref0qyrstchf8dxzeygtsejwfqu8ckhwl2qj5m8am7lmupxk3vkvdjm8pawjpmesjfapvsqw96pa46c2z0kk7letrxf7mkltwz54fwpxc7kc79mm5kce3rwn5ssl009zwsra2spppwgrx25s9k5hq65f69l4jz2tjmqgy0pl49qmtaj3nudk6wglwe2hpa327hydlchtyq9av6wjd6hu68e04ahwk9a9n2kt0kj3nj99nue65awtu5cwwcpjs"
|
||||
let vk2 =
|
||||
"zxviews1qdjagrrpqqqqpq8es75mlufakef0qyrstchf8dxzeygtsejwfqu8ckhwl2qj5m8am7lmupxk3vkvdjm8pawjpmesjfapvsqw96pa46c2z0kk7letrxf7mkltwz54fwpxc7kc79mm5kce3rwn5ssl009zwsra2spppwgrx25s9k5hq65f69l4jz2tjmqgy0pl49qmtaj3nudk6wglwe2hpa327hydlchtyq9av6wjd6hu68e04ahwk9a9n2kt0kj3nj99nue65awtu5cwwcpjs"
|
||||
let vk3 =
|
||||
"uview1u833rp8yykd7h4druwht6xp6k8krle45fx8hqsw6vzw63n24atxpcatws82z092kryazuu6d7rayyut8m36wm4wpjy2z8r9hj48fx5pf49gw4sjrq8503qpz3vqj5hg0vg9vsqeasg5qjuyh94uyfm7v76udqcm2m0wfc25hcyqswcn56xxduq3xkgxkr0l73cjy88fdvf90eq5fda9g6x7yv7d0uckpevxg6540wc76xrc4axxvlt03ptaa2a0rektglmdy68656f3uzcdgqqyu0t7wk5cvwghyyvgqc0rp3vgu5ye4nd236ml57rjh083a2755qemf6dk6pw0qrnfm7246s8eg2hhzkzpf9h73chhng7xhmyem2sjh8rs2m9nhfcslsgenm"
|
||||
it "returns 401 with bad session" $ do
|
||||
req <-
|
||||
testPostJson "/api/ownervk" $
|
||||
|
@ -768,7 +742,7 @@ main = do
|
|||
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
|
||||
req
|
||||
getResponseStatus res `shouldBe` badRequest400
|
||||
it "succeeds with correct key" $ do
|
||||
it "succeeds with correct Sapling key" $ do
|
||||
req <-
|
||||
testPostJson "/api/ownervk" $
|
||||
A.object ["payload" A..= (vk1 :: String)]
|
||||
|
@ -778,6 +752,26 @@ main = do
|
|||
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
|
||||
req
|
||||
getResponseStatus res `shouldBe` created201
|
||||
it "succeeds with correct Unified key and UA" $ do
|
||||
req <-
|
||||
testPostJson "/api/ownervk" $
|
||||
A.object ["payload" A..= (vk3 :: String)]
|
||||
res <-
|
||||
httpLBS $
|
||||
setRequestQueryString
|
||||
[("session", Just "35bfb9c2-9ad2-4fe5-daad-99d63b8dcdaa")]
|
||||
req
|
||||
getResponseStatus res `shouldBe` created201
|
||||
xit "succeeds with correct Unified key and Sapling address" $ do
|
||||
req <-
|
||||
testPostJson "/api/ownervk" $
|
||||
A.object ["payload" A..= (vk3 :: String)]
|
||||
res <-
|
||||
httpLBS $
|
||||
setRequestQueryString
|
||||
[("session", Just "35bfb9c2-a92d-4fe5-daad-99d63b8dcdaa")]
|
||||
req
|
||||
getResponseStatus res `shouldBe` created201
|
||||
around handleDb $
|
||||
describe "Database actions" $ do
|
||||
describe "authentication" $ do
|
||||
|
@ -866,6 +860,9 @@ main = do
|
|||
""
|
||||
""
|
||||
"testToken1234"
|
||||
0
|
||||
0
|
||||
0
|
||||
let ordTest = val myOrder
|
||||
case ordTest of
|
||||
Doc oT -> access p master "test" (insert_ "orders" oT)
|
||||
|
@ -909,7 +906,7 @@ main = do
|
|||
xit "logins are added to db" $ \p -> do
|
||||
_ <-
|
||||
access p master "test" (Database.MongoDB.delete (select [] "txs"))
|
||||
_ <- scanZcash loadedConfig p
|
||||
_ <- scanZcash' loadedConfig p
|
||||
threadDelay 1000000
|
||||
t <- access p master "test" $ findOne (select [] "txs")
|
||||
let s = parseZGoTxBson =<< t
|
||||
|
@ -922,7 +919,7 @@ main = do
|
|||
master
|
||||
"test"
|
||||
(Database.MongoDB.delete (select [] "payments"))
|
||||
_ <- scanZcash loadedConfig p
|
||||
_ <- scanZcash' loadedConfig p
|
||||
threadDelay 1000000
|
||||
t <- access p master "test" $ findOne (select [] "payments")
|
||||
let s = (cast' . Doc) =<< t
|
||||
|
@ -1158,17 +1155,40 @@ unwrapDoc _ = []
|
|||
startAPI :: Config -> IO ()
|
||||
startAPI config = do
|
||||
putStrLn "Starting test server ..."
|
||||
pipe <- connect $ host "127.0.0.1"
|
||||
c <- access pipe master "zgo" (auth "zgo" "zcashrules")
|
||||
pipe <- connect $ host $ c_dbHost config
|
||||
c <- access pipe master "zgo" (auth (c_dbUser config) (c_dbPassword config))
|
||||
let appRoutes = routes pipe config
|
||||
_ <- forkIO (scotty 3000 appRoutes)
|
||||
_ <-
|
||||
access pipe master "test" (Database.MongoDB.delete (select [] "wootokens"))
|
||||
_ <- access pipe master "test" (Database.MongoDB.delete (select [] "users"))
|
||||
_ <- access pipe master "test" (Database.MongoDB.delete (select [] "items"))
|
||||
_ <- access pipe master "test" (Database.MongoDB.delete (select [] "orders"))
|
||||
access
|
||||
pipe
|
||||
master
|
||||
(c_dbName config)
|
||||
(Database.MongoDB.delete (select [] "wootokens"))
|
||||
_ <-
|
||||
access pipe master "test" (Database.MongoDB.delete (select [] "xerotokens"))
|
||||
access
|
||||
pipe
|
||||
master
|
||||
(c_dbName config)
|
||||
(Database.MongoDB.delete (select [] "users"))
|
||||
_ <-
|
||||
access
|
||||
pipe
|
||||
master
|
||||
(c_dbName config)
|
||||
(Database.MongoDB.delete (select [] "items"))
|
||||
_ <-
|
||||
access
|
||||
pipe
|
||||
master
|
||||
(c_dbName config)
|
||||
(Database.MongoDB.delete (select [] "orders"))
|
||||
_ <-
|
||||
access
|
||||
pipe
|
||||
master
|
||||
(c_dbName config)
|
||||
(Database.MongoDB.delete (select [] "xerotokens"))
|
||||
let myUser =
|
||||
User
|
||||
(Just (read "6272a90f2b05a74cf1000001" :: ObjectId))
|
||||
|
@ -1193,8 +1213,25 @@ startAPI config = do
|
|||
1613487
|
||||
"8ea140fbb30615d6cae383c4f62f3ad9afb10b804f63138d5b53990bd56e0162"
|
||||
True
|
||||
let myUser3 =
|
||||
User
|
||||
(Just (read "6272a90f2b05a74cf1500003" :: ObjectId))
|
||||
"u15hjz9v46azzmdept050heh8795qxzwy2pykg097lg69jpk4qzah90cj2q4amq0c07gta60x8qgw00qewcy3hg9kv9h6zjkh3jc66vr40u6uu2dxmqkqhypud95vm0gq7y5ga7c8psdqgthsrwvgd676a2pavpcd4euwwapgackxa3qhvga0wnl0k6vncskxlq94vqwjd7zepy3qd5jh"
|
||||
"35bfb9c2-9ad2-4fe5-daad-99d63b8dcdaa"
|
||||
1613487
|
||||
"8ea140fbb30615d6cae383c4f62f3ad9afb10b804f63138d5b53990bd56e0162"
|
||||
True
|
||||
let myUser4 =
|
||||
User
|
||||
(Just (read "6272a90f2b05a74cf7500003" :: ObjectId))
|
||||
"zs1fau9x305eztcdm5f08q9uc4hmvvjpjrgjcwcj0mjwhd83pdj0j92rxwqp6zkjmz3e49ej4xrcc8"
|
||||
"35bfb9c2-a92d-4fe5-daad-99d63b8dcdaa"
|
||||
1613487
|
||||
"8ea140fbb30615d6cae383c4f62f3ad9afb10b804f63138d5b53990bd56e0162"
|
||||
True
|
||||
let userList =
|
||||
map unwrapDoc $ filter filterDocs $ val <$> [myUser, myUser1, myUser2]
|
||||
map unwrapDoc $
|
||||
filter filterDocs $ val <$> [myUser, myUser1, myUser2, myUser3, myUser4]
|
||||
_ <- access pipe master "test" (insertAll_ "users" userList)
|
||||
let myOwner =
|
||||
Owner
|
||||
|
@ -1223,6 +1260,7 @@ startAPI config = do
|
|||
False
|
||||
""
|
||||
""
|
||||
False
|
||||
let myOwner1 =
|
||||
Owner
|
||||
(Just (read "627ad3492b05a76be3000008"))
|
||||
|
@ -1250,6 +1288,63 @@ startAPI config = do
|
|||
False
|
||||
""
|
||||
""
|
||||
False
|
||||
let myOwner2 =
|
||||
Owner
|
||||
(Just (read "627ad3492b05a76be3700008"))
|
||||
"u15hjz9v46azzmdept050heh8795qxzwy2pykg097lg69jpk4qzah90cj2q4amq0c07gta60x8qgw00qewcy3hg9kv9h6zjkh3jc66vr40u6uu2dxmqkqhypud95vm0gq7y5ga7c8psdqgthsrwvgd676a2pavpcd4euwwapgackxa3qhvga0wnl0k6vncskxlq94vqwjd7zepy3qd5jh"
|
||||
"Test shop 3"
|
||||
"usd"
|
||||
False
|
||||
0
|
||||
False
|
||||
0
|
||||
"Roxy"
|
||||
"Foo"
|
||||
"roxy@zgo.cash"
|
||||
"1 Main St"
|
||||
"Mpls"
|
||||
"Minnesota"
|
||||
"55401"
|
||||
""
|
||||
"missyfoo.io"
|
||||
"United States"
|
||||
True
|
||||
False
|
||||
False
|
||||
(UTCTime (fromGregorian 2024 8 6) (secondsToDiffTime 0))
|
||||
False
|
||||
""
|
||||
""
|
||||
False
|
||||
let myOwner3 =
|
||||
Owner
|
||||
(Just (read "627ad3492b05a76be3750008"))
|
||||
"zs1fau9x305eztcdm5f08q9uc4hmvvjpjrgjcwcj0mjwhd83pdj0j92rxwqp6zkjmz3e49ej4xrcc8"
|
||||
"Test shop 4"
|
||||
"usd"
|
||||
False
|
||||
0
|
||||
False
|
||||
0
|
||||
"Roxy"
|
||||
"Foo"
|
||||
"roxy@zgo.cash"
|
||||
"1 Main St"
|
||||
"Mpls"
|
||||
"Minnesota"
|
||||
"55401"
|
||||
""
|
||||
"missyfoo.io"
|
||||
"United States"
|
||||
True
|
||||
False
|
||||
False
|
||||
(UTCTime (fromGregorian 2024 8 6) (secondsToDiffTime 0))
|
||||
False
|
||||
""
|
||||
""
|
||||
False
|
||||
_ <- access pipe master "test" (Database.MongoDB.delete (select [] "owners"))
|
||||
let o = val myOwner
|
||||
case o of
|
||||
|
@ -1259,6 +1354,14 @@ startAPI config = do
|
|||
case o1 of
|
||||
Doc d1 -> access pipe master "test" (insert_ "owners" d1)
|
||||
_ -> fail "Couldn't save Owner1 in DB"
|
||||
let o2 = val myOwner2
|
||||
case o2 of
|
||||
Doc d2 -> access pipe master "test" (insert_ "owners" d2)
|
||||
_ -> fail "Couldn't save Owner2 in DB"
|
||||
let o3 = val myOwner3
|
||||
case o3 of
|
||||
Doc d3 -> access pipe master "test" (insert_ "owners" d3)
|
||||
_ -> fail "Couldn't save Owner2 in DB"
|
||||
_ <- access pipe master "test" (Database.MongoDB.delete (select [] "orders"))
|
||||
myTs <- liftIO getCurrentTime
|
||||
let myOrder =
|
||||
|
@ -1277,6 +1380,9 @@ startAPI config = do
|
|||
""
|
||||
""
|
||||
"testToken1234"
|
||||
0
|
||||
0
|
||||
0
|
||||
let ordTest = val myOrder
|
||||
case ordTest of
|
||||
Doc oT -> access pipe master "test" (insert_ "orders" oT)
|
||||
|
@ -1342,7 +1448,10 @@ instance Arbitrary ZGoOrder where
|
|||
pd <- arbitrary
|
||||
eI <- arbitrary
|
||||
sc <- arbitrary
|
||||
ZGoOrder i a s ts c cur p t tZ l pd eI sc <$> arbitrary
|
||||
tk <- arbitrary
|
||||
qT <- arbitrary
|
||||
qV <- arbitrary
|
||||
ZGoOrder i a s ts c cur p t tZ l pd eI sc tk qT qV <$> arbitrary
|
||||
|
||||
instance Arbitrary LineItem where
|
||||
arbitrary = do
|
||||
|
@ -1381,7 +1490,33 @@ instance Arbitrary Owner where
|
|||
exp <- arbitrary
|
||||
payconf <- arbitrary
|
||||
vk <- arbitrary
|
||||
Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv exp payconf vk <$>
|
||||
cT <- arbitrary
|
||||
Owner
|
||||
i
|
||||
a
|
||||
n
|
||||
c
|
||||
t
|
||||
tV
|
||||
v
|
||||
vV
|
||||
f
|
||||
l
|
||||
e
|
||||
s
|
||||
ct
|
||||
st
|
||||
p
|
||||
ph
|
||||
w
|
||||
co
|
||||
paid
|
||||
zats
|
||||
inv
|
||||
exp
|
||||
payconf
|
||||
vk
|
||||
cT <$>
|
||||
arbitrary
|
||||
|
||||
instance Arbitrary Item where
|
||||
|
|
|
@ -1,18 +1,18 @@
|
|||
cabal-version: 1.12
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.35.1.
|
||||
-- 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.6.0
|
||||
version: 1.8.1
|
||||
synopsis: Haskell Back-end for the ZGo point-of-sale application
|
||||
description: Please see the README at <https://git.vergara.tech/Vergara_Tech//zgo-backend#readme>
|
||||
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:
|
||||
|
|
Loading…
Reference in New Issue