diff --git a/CHANGELOG.md b/CHANGELOG.md index 9f26074..2712b8b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,9 +6,22 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [Unreleased] -## Changed +### 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 - MongoDB driver updated to support MongoDB 6. +- Full validation of Sapling addresses to parser. + +### Removed + +- `makeZcashCall` function moved to the generic `zcash-haskell` library. +- `RpcResponse`, `RpcCall` types moved to the generic `zcash-haskell` library. ## [1.7.0] diff --git a/app/Tasks.hs b/app/Tasks.hs index 0f8a12d..62027da 100644 --- a/app/Tasks.hs +++ b/app/Tasks.hs @@ -23,7 +23,8 @@ 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 diff --git a/src/Owner.hs b/src/Owner.hs index e1dbfa2..803fb65 100644 --- a/src/Owner.hs +++ b/src/Owner.hs @@ -14,35 +14,33 @@ 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 + } 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) = @@ -276,21 +274,19 @@ instance Val Owner where ] -- | 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 +304,23 @@ 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 + } deriving (Eq, Show, Generic) instance FromJSON OwnerSettings where parseJSON = @@ -424,6 +418,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]] @@ -450,14 +448,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 85d1ac8..763c512 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -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,47 +66,21 @@ 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) @@ -399,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 @@ -416,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 @@ -441,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 $ @@ -1203,37 +1228,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" @@ -1467,25 +1511,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 @@ -1527,7 +1570,7 @@ listTxs user pwd a confs = do user pwd "z_listreceivedbyaddress" - [Data.Aeson.String a, Data.Aeson.Number $ Scientific.scientific confs 0] :: IO + [Data.Aeson.String a, Data.Aeson.Number $ SC.scientific confs 0] :: IO (Either HttpException (Response (RpcResponse [ZcashTx]))) case res of Right txList -> do @@ -1725,7 +1768,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 @@ -1831,4 +1874,253 @@ 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") 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 a95f0ac..90f0c8e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -45,7 +45,7 @@ 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 diff --git a/stack.yaml.lock b/stack.yaml.lock index cb196ff..8cc2c00 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 diff --git a/test/Spec.hs b/test/Spec.hs index 5cd7576..e1da300 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -59,7 +59,7 @@ main = do 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,7 +81,7 @@ main = do Right m' -> m_session m' `shouldBe` U.fromString "ad8477d3-4fdd-4c97-90b2-76630b5f77e1" - it "parse Zingo memo" $ do + it "parse Zingo memo - Sapling" $ do let m = runParser pZGoMemo @@ -92,6 +92,42 @@ main = do 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 @@ -262,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") ] @@ -655,6 +691,8 @@ main = do "zxviews1qdjagrrpqqqqpq8es75mlu6rref0qyrstchf8dxzeygtsejwfqu8ckhwl2qj5m8am7lmupxk3vkvdjm8pawjpmesjfapvsqw96pa46c2z0kk7letrxf7mkltwz54fwpxc7kc79mm5kce3rwn5ssl009zwsra2spppwgrx25s9k5hq65f69l4jz2tjmqgy0pl49qmtaj3nudk6wglwe2hpa327hydlchtyq9av6wjd6hu68e04ahwk9a9n2kt0kj3nj99nue65awtu5cwwcpjs" let vk2 = "zxviews1qdjagrrpqqqqpq8es75mlufakef0qyrstchf8dxzeygtsejwfqu8ckhwl2qj5m8am7lmupxk3vkvdjm8pawjpmesjfapvsqw96pa46c2z0kk7letrxf7mkltwz54fwpxc7kc79mm5kce3rwn5ssl009zwsra2spppwgrx25s9k5hq65f69l4jz2tjmqgy0pl49qmtaj3nudk6wglwe2hpa327hydlchtyq9av6wjd6hu68e04ahwk9a9n2kt0kj3nj99nue65awtu5cwwcpjs" + let vk3 = + "uview1u833rp8yykd7h4druwht6xp6k8krle45fx8hqsw6vzw63n24atxpcatws82z092kryazuu6d7rayyut8m36wm4wpjy2z8r9hj48fx5pf49gw4sjrq8503qpz3vqj5hg0vg9vsqeasg5qjuyh94uyfm7v76udqcm2m0wfc25hcyqswcn56xxduq3xkgxkr0l73cjy88fdvf90eq5fda9g6x7yv7d0uckpevxg6540wc76xrc4axxvlt03ptaa2a0rektglmdy68656f3uzcdgqqyu0t7wk5cvwghyyvgqc0rp3vgu5ye4nd236ml57rjh083a2755qemf6dk6pw0qrnfm7246s8eg2hhzkzpf9h73chhng7xhmyem2sjh8rs2m9nhfcslsgenm" it "returns 401 with bad session" $ do req <- testPostJson "/api/ownervk" $ @@ -695,7 +733,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)] @@ -705,6 +743,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 @@ -1143,8 +1201,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 @@ -1200,6 +1275,60 @@ startAPI config = do 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 + "" + "" + 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 + "" + "" _ <- access pipe master "test" (Database.MongoDB.delete (select [] "owners")) let o = val myOwner case o of @@ -1209,6 +1338,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 =