diff --git a/CHANGELOG.md b/CHANGELOG.md index 28ec2bc..d87c1a2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,27 @@ 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.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 diff --git a/app/Tasks.hs b/app/Tasks.hs index 0f8a12d..12ffa3a 100644 --- a/app/Tasks.hs +++ b/app/Tasks.hs @@ -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!" diff --git a/package.yaml b/package.yaml index 6953890..4f4d860 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: zgo-backend -version: 1.7.0 +version: 1.8.0 git: "https://git.vergara.tech/Vergara_Tech/zgo-backend" license: BOSL author: "Rene Vergara" diff --git a/src/Order.hs b/src/Order.hs index 1aeefdb..8ea88ca 100644 --- a/src/Order.hs +++ b/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) diff --git a/src/Owner.hs b/src/Owner.hs index e1dbfa2..431b112 100644 --- a/src/Owner.hs +++ b/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 diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 99d5cde..da23781 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -15,6 +15,7 @@ import Control.Monad.IO.Class import Crypto.RNG (newCryptoRNGState, runCryptoRNGT) import Crypto.RNG.Utils (randomString) import Data.Aeson +import Data.Aeson (decodeFileStrict) import Data.Array import qualified Data.Bson as B import qualified Data.ByteArray as BA @@ -25,7 +26,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 +38,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 +53,7 @@ import Numeric import Order import Owner import Payment +import System.IO import System.IO.Unsafe import System.Random import Test.QuickCheck @@ -66,88 +67,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 +159,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 +245,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 +274,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 +321,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 +342,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 +374,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 +386,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 +467,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 +591,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 +725,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 +762,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 +802,8 @@ routes pipe config = do [ "reportType" .= (8 :: Integer) , "order" .= - (Nothing :: Maybe ZGoOrder) + (Nothing :: Maybe + ZGoOrder) , "shop" .= (Nothing :: Maybe String) ]) @@ -959,7 +973,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 +1044,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 +1208,7 @@ routes pipe config = do False "" "" + False status accepted202 post "/api/ownersettings" $ do s <- param "session" @@ -1218,37 +1237,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 + if isValidUnifiedAddress $ + C.pack . T.unpack $ uaddress u' + then 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 + else 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 +1340,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 +1408,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 +1437,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 +1573,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 +1632,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 +1766,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 +1830,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 +1936,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]) diff --git a/src/ZGoTx.hs b/src/ZGoTx.hs index 8f786b8..3749eb4 100644 --- a/src/ZGoTx.hs +++ b/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 + if isValidUnifiedAddress (E.encodeUtf8 $ "u1" <> T.pack a) + then pure $ Address $ T.pack ("u1" <> a) + else 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) && diff --git a/stack.yaml b/stack.yaml index d65ab03..8f78da2 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,7 +17,7 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-20.23 +resolver: lts-21.17 #url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/4.yaml # User packages to be built. @@ -45,11 +45,14 @@ extra-deps: - git: https://github.com/reach-sh/haskell-hexstring.git commit: 085c16fb21b9f856a435a3faab980e7e0b319341 - git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git - commit: fef3d3af35a09db718cddb8fc9166b2d2691a744 + commit: 1d558fc646a7758d60a721124812070de222c2e1 - 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 diff --git a/stack.yaml.lock b/stack.yaml.lock index 552f32f..d88e25b 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -16,15 +16,15 @@ packages: commit: 085c16fb21b9f856a435a3faab980e7e0b319341 git: https://github.com/reach-sh/haskell-hexstring.git - completed: - commit: fef3d3af35a09db718cddb8fc9166b2d2691a744 + commit: 1d558fc646a7758d60a721124812070de222c2e1 git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git name: zcash-haskell pantry-tree: - sha256: ec7782cf2646da17548d59af0ea98dcbaac1b6c2176258c696a7f508db6dbc21 - size: 1126 - version: 0.1.0 + sha256: eab3c6817bb3cb5738725824d16eb023cb2967ef3bbaa8f8252524602f606dbb + size: 1229 + version: 0.2.0 original: - commit: fef3d3af35a09db718cddb8fc9166b2d2691a744 + commit: 1d558fc646a7758d60a721124812070de222c2e1 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: 85d2382958c178491d3fe50d770a624621f5ab456beef7d31ac7521f780c9bc7 + size: 640042 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/17.yaml + original: lts-21.17 diff --git a/test/Spec.hs b/test/Spec.hs index 5f17d11..35d60cf 100644 --- a/test/Spec.hs +++ b/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 diff --git a/zgo-backend.cabal b/zgo-backend.cabal index 264cfbf..0d59748 100644 --- a/zgo-backend.cabal +++ b/zgo-backend.cabal @@ -1,11 +1,11 @@ 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.35.2. -- -- see: https://github.com/sol/hpack name: zgo-backend -version: 1.6.0 +version: 1.8.0 synopsis: Haskell Back-end for the ZGo point-of-sale application description: Please see the README at category: Web