diff --git a/CHANGELOG.md b/CHANGELOG.md index f6da509..84a4955 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,13 +6,43 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [Unreleased] +## [1.0.0] - 2022-07-27 + +### Added + +- New functionality to read transactions for the given viewing keys +- New functionality to mark orders as paid once payment is found on-chain +- New `Config` type to house the configuration parameters +- New field in `Owner` type to store toggle for payment confirmation +- New field in `Owner` type to store viewing key + +### Changed + +- Added chronological sorting to list of orders +- Added logic in `/api/owner` endpoint to validate viewing key before saving +- Updated tests for `/api/owner` to account for invalid viewing keys +- Added alphabetic sorting to list of items +- Refactored code to use new `Config` type +- Enhance `decodeHexText` to support Unicode +- Enhance `encodeHexText` to support Unicode +- Update tests for encode/decode of memos + +### Fixed + +- Fixed the PIN generation +- Fixed calculation of order total to ensure 8 decimal places +- Fixed test for looking for an order with incorrect ID +- Fixed payment scan to focus only on new transactions + +## [0.1.0.2] - 2022-05-25 + ### Added - Changelog - `paid` field in ZGoOrder type - Test for `api/order/:id` endpoint with an invalid ID -## Fixed +### Fixed - Bug #1: crash when invalid ID was provided to `api/order/:id` diff --git a/app/Main.hs b/app/Main.hs index 84fd1f6..76b677f 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -2,9 +2,8 @@ module Main where +import Config import Control.Concurrent (forkIO) -import Data.Configurator -import Data.SecureMem import Database.MongoDB import Network.Wai.Handler.Warp (defaultSettings, setPort) import Network.Wai.Handler.WarpTLS (runTLS, tlsSettings) @@ -14,40 +13,32 @@ import ZGoBackend main :: IO () main = do putStrLn "Reading config..." - config <- load ["zgo.cfg"] - dbHost <- require config "dbHost" - dbName <- require config "dbName" - dbUser <- require config "dbUser" - dbPassword <- require config "dbPassword" - nodeAddress <- require config "nodeAddress" - nodeUser <- require config "nodeUser" - nodePwd <- require config "nodePassword" - passkey <- secureMemFromByteString <$> require config "passkey" - port <- require config "port" - useTls <- require config "tls" - cert <- require config "certificate" - key <- require config "key" + loadedConfig <- loadZGoConfig "zgo.cfg" let myTlsSettings = - if useTls - then Just $ tlsSettings cert key + if c_useTls loadedConfig + then Just $ + tlsSettings (c_certificate loadedConfig) (c_key loadedConfig) else Nothing putStrLn "Starting Server..." - pipe <- connect $ host dbHost - j <- access pipe master dbName (auth dbUser dbPassword) + pipe <- connect $ host (c_dbHost loadedConfig) + j <- + access + pipe + master + (c_dbName loadedConfig) + (auth (c_dbUser loadedConfig) (c_dbPassword loadedConfig)) if j then putStrLn "Connected to MongoDB!" else fail "MongoDB connection failed!" - _ <- forkIO (setInterval 60 (checkZcashPrices pipe dbName)) - _ <- - forkIO (setInterval 75 (scanZcash nodeAddress pipe dbName nodeUser nodePwd)) - _ <- forkIO (setInterval 60 (checkPayments pipe dbName)) - _ <- forkIO (setInterval 60 (expireOwners pipe dbName)) - _ <- - forkIO - (setInterval 60 (updateLogins nodeUser nodePwd nodeAddress pipe dbName)) - let appRoutes = routes pipe dbName passkey nodeAddress nodeUser nodePwd + _ <- forkIO (setInterval 60 (checkZcashPrices pipe (c_dbName loadedConfig))) + _ <- forkIO (setInterval 75 (scanZcash loadedConfig pipe)) + _ <- forkIO (setInterval 90 (scanPayments loadedConfig pipe)) + _ <- forkIO (setInterval 60 (checkPayments pipe (c_dbName loadedConfig))) + _ <- forkIO (setInterval 60 (expireOwners pipe (c_dbName loadedConfig))) + _ <- forkIO (setInterval 60 (updateLogins pipe loadedConfig)) + let appRoutes = routes pipe loadedConfig case myTlsSettings of - Nothing -> scotty port appRoutes + Nothing -> scotty (c_port loadedConfig) appRoutes Just tls -> do apiCore <- scottyApp appRoutes - runTLS tls (setPort port defaultSettings) apiCore + runTLS tls (setPort (c_port loadedConfig) defaultSettings) apiCore diff --git a/package.yaml b/package.yaml index 58a78c0..b280c86 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: zgo-backend -version: 0.1.0.2 +version: 1.0.0 git: "https://gitlab.com/pitmutt/zgo-backend" license: BOSL author: "Rene Vergara" @@ -48,6 +48,9 @@ library: - vector - wai-cors - warp-tls + - hexstring + - configurator + - scientific executables: zgo-backend-exe: diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 index 0000000..1abfcef --- /dev/null +++ b/src/Config.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Config where + +import qualified Data.ByteString as BS +import Data.Configurator +import Data.SecureMem +import qualified Data.Text as T + +data Config = + Config + { c_dbHost :: String + , c_dbName :: T.Text + , c_dbUser :: T.Text + , c_dbPassword :: T.Text + , c_passkey :: SecureMem + , c_nodeAddress :: T.Text + , c_nodeUser :: BS.ByteString + , c_nodePwd :: BS.ByteString + , c_port :: Int + , c_useTls :: Bool + , c_certificate :: String + , c_key :: String + } + deriving (Eq, Show) + +loadZGoConfig :: Worth FilePath -> IO Config +loadZGoConfig path = do + config <- load [path] + dbHost <- require config "dbHost" + dbName <- require config "dbName" + dbUser <- require config "dbUser" + dbPassword <- require config "dbPassword" + nodeAddress <- require config "nodeAddress" + nodeUser <- require config "nodeUser" + nodePwd <- require config "nodePassword" + passkey <- secureMemFromByteString <$> require config "passkey" + port <- require config "port" + useTls <- require config "tls" + cert <- require config "certificate" + key <- require config "key" + return $ + Config + dbHost + dbName + dbUser + dbPassword + passkey + nodeAddress + nodeUser + nodePwd + port + useTls + cert + key diff --git a/src/Item.hs b/src/Item.hs index 95b18b2..6fef76e 100644 --- a/src/Item.hs +++ b/src/Item.hs @@ -84,7 +84,8 @@ instance Val Item where -- Database actions findItems :: T.Text -> Action IO [Document] -findItems a = rest =<< find (select ["owner" =: a] "items") +findItems a = + rest =<< find (select ["owner" =: a] "items") {sort = ["name" =: (1 :: Int)]} upsertItem :: Item -> Action IO () upsertItem i = do diff --git a/src/Order.hs b/src/Order.hs index 986ac0e..a8d01ef 100644 --- a/src/Order.hs +++ b/src/Order.hs @@ -188,7 +188,7 @@ updateOrderTotals o = (qprice o) (newTotal o) (if qprice o /= 0 - then newTotal o / qprice o + then roundZec (newTotal o / qprice o) else 0) (qlines o) (qpaid o) @@ -205,7 +205,18 @@ findOrderById :: String -> Action IO (Maybe Document) findOrderById i = findOne (select ["_id" =: (read i :: B.ObjectId)] "orders") findAllOrders :: T.Text -> Action IO [Document] -findAllOrders a = rest =<< find (select ["address" =: a] "orders") +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") + +markOrderPaid :: (String, Double) -> Action IO () +markOrderPaid (i, a) = do + let + modify + (select ["_id" =: (read i :: B.ObjectId), "totalZec" =: a] "orders") + ["$set" =: ["paid" =: True]] + +-- | Helper function to round to 8 decimal places +roundZec :: Double -> Double +roundZec n = fromInteger (round $ n * (10 ^ 8)) / (10.0 ^^ 8) diff --git a/src/Owner.hs b/src/Owner.hs index c2acc6e..7dd8cef 100644 --- a/src/Owner.hs +++ b/src/Owner.hs @@ -6,6 +6,7 @@ module Owner where import Data.Aeson import qualified Data.Bson as B +import Data.Maybe import qualified Data.Text as T import Data.Time.Clock import Data.Typeable @@ -37,11 +38,13 @@ data Owner = , ozats :: Bool , oinvoices :: Bool , oexpiration :: UTCTime + , opayconf :: Bool + , oviewkey :: 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) = + 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) = case i of Just oid -> object @@ -67,6 +70,8 @@ instance ToJSON Owner where , "zats" .= zats , "invoices" .= inv , "expiration" .= eTs + , "payconf" .= pc + , "viewkey" .= vk ] Nothing -> object @@ -92,6 +97,8 @@ instance ToJSON Owner where , "zats" .= zats , "invoices" .= inv , "expiration" .= eTs + , "payconf" .= pc + , "viewkey" .= vk ] instance FromJSON Owner where @@ -119,6 +126,8 @@ instance FromJSON Owner where zats <- obj .: "zats" inv <- obj .: "invoices" ets <- obj .: "expiration" + pc <- obj .:? "payconf" + vk <- obj .:? "viewkey" pure $ Owner (if not (null i) @@ -145,6 +154,8 @@ instance FromJSON Owner where zats inv ets + (fromMaybe False pc) + (fromMaybe "" vk) instance Val Owner where cast' (Doc d) = do @@ -170,9 +181,12 @@ instance Val Owner where zats <- B.lookup "zats" d inv <- B.lookup "invoices" d ets <- B.lookup "expiration" d - Just (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv ets) + pc <- B.lookup "payconf" d + vk <- B.lookup "viewKey" d + Just + (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) 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) = + 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) = case i of Just oid -> Doc @@ -198,6 +212,8 @@ instance Val Owner where , "zats" =: zats , "invoices" =: inv , "expiration" =: ets + , "payconf" =: pc + , "viewKey" =: vk ] Nothing -> Doc @@ -222,6 +238,8 @@ instance Val Owner where , "zats" =: zats , "invoices" =: inv , "expiration" =: ets + , "payconf" =: pc + , "viewKey" =: vk ] -- Database actions diff --git a/src/User.hs b/src/User.hs index da2ae10..7e933d6 100644 --- a/src/User.hs +++ b/src/User.hs @@ -99,9 +99,9 @@ validateUser session = (select ["session" =: session] "users") ["$set" =: ["validated" =: True]] -generatePin :: IO T.Text -generatePin = do - g <- newStdGen +generatePin :: Int -> IO T.Text +generatePin s = do + let g = mkStdGen s pure $ T.pack (padLeft (show . head $ randomRs (1 :: Integer, 10000000) g) '0' 7) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index e7b157b..cf4e6f3 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -2,9 +2,11 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} module ZGoBackend where +import Config import Control.Concurrent (forkIO, threadDelay) import Control.Monad import Control.Monad.IO.Class @@ -14,9 +16,13 @@ import qualified Data.Bson as B import qualified Data.ByteString as BS import Data.Char import qualified Data.HashMap.Strict as HM +import Data.HexString import Data.Maybe +import qualified Data.Scientific as Scientific import Data.SecureMem import qualified Data.Text as T +import qualified Data.Text.Encoding as E +import Data.Text.Encoding.Error (lenientDecode) import qualified Data.Text.Lazy as L import Data.Time.Clock import Data.Time.Clock.POSIX @@ -63,9 +69,9 @@ instance ToJSON RpcCall where -- | A type to model the response of the Zcash RPC data RpcResponse r = MakeRpcResponse - { err :: Maybe T.Text + { err :: Maybe RpcError , respId :: T.Text - , result :: r + , result :: Maybe r } deriving (Show, Generic, ToJSON) @@ -74,6 +80,20 @@ instance (FromJSON r) => FromJSON (RpcResponse r) where 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 @@ -118,7 +138,7 @@ instance FromJSON ZcashTx where aZ <- obj .: "amountZat" bh <- obj .: "blockheight" bt <- obj .: "blocktime" - c <- obj .: "change" + c <- obj .:? "change" conf <- obj .: "confirmations" m <- obj .: "memo" pure $ @@ -128,9 +148,9 @@ instance FromJSON ZcashTx where aZ bh bt - c + (fromMaybe False c) conf - (T.pack (filter (/= '\NUL') $ decodeHexText m)) + (T.filter (/= '\NUL') $ decodeHexText m) instance ToJSON ZcashTx where toJSON (ZcashTx t a aZ bh bt c conf m) = @@ -156,23 +176,123 @@ instance Arbitrary ZcashTx where cm <- arbitrary 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) + +instance FromJSON AddressGroup where + parseJSON = + withObject "AddressGroup" $ \obj -> do + s <- obj .: "source" + t <- obj .:? "transparent" + sap <- obj .:? "sapling" + uni <- obj .:? "unified" + sL <- processSapling sap s + tL <- processTransparent t s + uL <- processUnified uni + return $ AddressGroup s tL (concat sL) (concat uL) + where + processTransparent c s1 = + case c of + Nothing -> return [] + Just x -> do + x' <- x .: "addresses" + return $ map (ZcashAddress s1 [Transparent] Nothing) x' + processSapling k s2 = + case k of + Nothing -> return [] + Just y -> mapM (processOneSapling s2) y + where processOneSapling sx = + withObject "Sapling" $ \oS -> do + oS' <- oS .: "addresses" + return $ map (ZcashAddress sx [Sapling] Nothing) oS' + processUnified u = + case u of + Nothing -> return [] + Just z -> mapM processOneAccount z + where processOneAccount = + withObject "UAs" $ \uS -> do + acct <- uS .: "account" + uS' <- uS .: "addresses" + mapM (processUAs acct) uS' + where + processUAs a = + withObject "UAs" $ \v -> do + addr <- v .: "address" + p <- v .: "receiver_types" + return $ ZcashAddress MnemonicSeed p a addr + +-- | Type for modelling the different address sources for Zcash 5.0.0 +data AddressSource + = LegacyRandom + | Imported + | ImportedWatchOnly + | KeyPool + | LegacySeed + | MnemonicSeed + deriving (Read, Show, Eq, Generic, ToJSON) + +instance FromJSON AddressSource where + parseJSON = + withText "AddressSource" $ \case + "legacy_random" -> return LegacyRandom + "imported" -> return Imported + "imported_watchonly" -> return ImportedWatchOnly + "keypool" -> return KeyPool + "legacy_hdseed" -> return LegacySeed + "mnemonic_seed" -> return MnemonicSeed + _ -> fail "Not a known address source" + +data ZcashPool + = Transparent + | Sprout + | Sapling + | Orchard + deriving (Show, Eq, Generic, ToJSON) + +instance FromJSON ZcashPool where + parseJSON = + withText "ZcashPool" $ \case + "p2pkh" -> return Transparent + "sprout" -> return Sprout + "sapling" -> return Sapling + "orchard" -> return Orchard + _ -> fail "Not a known Zcash pool" + +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) = + T.unpack (T.take 8 a) ++ + "..." ++ T.unpack (T.takeEnd 8 a) ++ " Pools: " ++ show p + -- | Helper function to turn a hex-encoded memo strings to readable text -decodeHexText :: String -> String -decodeHexText hexText - -- | chunk == "00" = decodeHexText (drop 2 hexText) - | null chunk = "" - | otherwise = chr (read ("0x" <> chunk)) : decodeHexText (drop 2 hexText) +decodeHexText :: String -> T.Text +decodeHexText h = E.decodeUtf8With lenientDecode $ BS.pack $ hexRead h where - chunk = take 2 hexText + hexRead hexText + | null chunk = [] + | otherwise = + fromIntegral (read ("0x" <> chunk)) : hexRead (drop 2 hexText) + where + chunk = take 2 hexText -- | Helper function to turn a string into a hex-encoded string -encodeHexText :: String -> String -encodeHexText t = mconcat (map padHex t) - where - padHex x = - if ord x < 16 - then "0" ++ (showHex . ord) x "" - else showHex (ord x) "" +encodeHexText :: T.Text -> String +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 @@ -204,8 +324,8 @@ zToZGoTx (ZcashTx t a aZ bh bt c conf m) = do if not (null reg) then do let sess = T.pack (fst $ head reg ! 1) - let addy = T.pack (fst $ head reg ! 2) - ZGoTx Nothing addy sess conf bt a t m + let nAddy = T.pack (fst $ head reg ! 2) + ZGoTx Nothing nAddy sess conf bt a t m else do if not (null reg2) then do @@ -262,7 +382,7 @@ sendPin nodeUser nodePwd nodeAddress addr pin = do [ object [ "address" .= addr , "amount" .= (0.00000001 :: Double) - , "memo" .= encodeHexText ("ZGo PIN: " ++ T.unpack pin) + , "memo" .= encodeHexText ("ZGo PIN: " <> pin) ] ]) ] @@ -285,7 +405,7 @@ addUser _ _ _ _ _ Nothing = return () --`debug` "addUser got Nothing" addUser nodeUser nodePwd p db node (Just tx) = do isNew <- liftIO $ isUserNew p db tx when isNew $ do - let newPin = unsafePerformIO generatePin + let newPin = unsafePerformIO (generatePin (fromIntegral $ blocktime tx)) _ <- sendPin nodeUser nodePwd node (address tx) newPin insert_ "users" @@ -327,16 +447,13 @@ upsertZGoTx coll t = do upsert (select ["txid" =: txid t] coll) (encodeZGoTxBson t) -- | Main API routes -routes :: - Pipe - -> T.Text - -> SecureMem - -> T.Text - -> BS.ByteString - -> BS.ByteString - -> ScottyM () -routes pipe db passkey nodeAddress nodeUser nodePwd = do - let run = access pipe master db +routes :: Pipe -> Config -> ScottyM () +routes pipe config = do + let run = access pipe master (c_dbName config) + let passkey = c_passkey config + let nodeUser = c_nodeUser config + let nodePwd = c_nodePwd config + let nodeAddress = c_nodeAddress config middleware $ cors $ const $ @@ -404,7 +521,13 @@ routes pipe db passkey nodeAddress nodeUser nodePwd = do --Get current blockheight from Zcash node get "/api/blockheight" $ do blockInfo <- makeZcashCall nodeUser nodePwd "getblock" ["-1"] - Web.Scotty.json (result (getResponseBody blockInfo :: RpcResponse Block)) + let content = getResponseBody blockInfo :: RpcResponse Block + if isNothing (err content) + then do + status ok200 + Web.Scotty.json $ fromMaybe (Block 0 0) (result content) + else do + status internalServerError500 --Get the ZGo node's shielded address get "/api/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress]) --Get owner by address @@ -428,8 +551,30 @@ routes pipe db passkey nodeAddress nodeUser nodePwd = do post "/api/owner" $ do o <- jsonData let q = payload (o :: Payload Owner) - _ <- liftIO $ run (upsertOwner q) - status created201 + known <- liftIO $ listAddresses nodeUser nodePwd + if not (opayconf q) + then do + _ <- liftIO $ run (upsertOwner q) + status created201 + else do + if oaddress q `elem` map addy known + then do + _ <- liftIO $ run (upsertOwner q) + status created201 + else do + vkInfo <- + makeZcashCall + nodeUser + nodePwd + "z_importviewingkey" + [Data.Aeson.String (oviewkey q), "no"] + let content = getResponseBody vkInfo :: RpcResponse Object + if isNothing (err content) + then do + _ <- liftIO $ run (upsertOwner q) + status created201 + else do + status internalServerError500 --Get items associated with the given address get "/api/items" $ do addr <- param "address" @@ -575,33 +720,101 @@ checkZcashPrices p db = do q <- getZcashPrices mapM_ (access p master db) (updatePrices (getResponseBody q)) --- | Function to check the ZGo full node for new txs -scanZcash :: T.Text -> Pipe -> T.Text -> BS.ByteString -> BS.ByteString -> IO () -scanZcash addr pipe db nodeUser nodePwd = do +-- | Function to search for transactions for an address +listTxs :: + BS.ByteString + -> BS.ByteString + -> T.Text + -> Integer + -> IO (Either T.Text [ZcashTx]) +listTxs user pwd a confs = do res <- + liftIO $ makeZcashCall - nodeUser - nodePwd + user + pwd "z_listreceivedbyaddress" - [Data.Aeson.String addr] - let txs = - filter (not . zchange) $ - result (getResponseBody res :: RpcResponse [ZcashTx]) - let r = - mkRegex - ".*ZGO::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12})\\sReply-To:\\s(zs[a-z0-9]{76}).*" - let p = - mkRegex - ".*ZGOp::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12}).*" - let k = map zToZGoTx (filter (matchTest r . T.unpack . zmemo) txs) - mapM_ (access pipe master db . upsertZGoTx "txs") k - let j = map zToZGoTx (filter (matchTest p . T.unpack . zmemo) txs) - mapM_ (access pipe master db . upsertPayment) j + [Data.Aeson.String a, Data.Aeson.Number $ Scientific.scientific confs 0] + let content = getResponseBody res :: RpcResponse [ZcashTx] + case err content of + Nothing -> + return $ Right $ filter (not . zchange) $ fromMaybe [] $ result content + Just e -> return $ Left $ "Error reading transactions: " <> emessage e + +-- | Function to check the ZGo full node for new txs +scanZcash :: Config -> Pipe -> IO () +scanZcash config pipe = do + myTxs <- + listTxs (c_nodeUser config) (c_nodePwd config) (c_nodeAddress config) 1 + case myTxs of + Right txs -> do + let r = + mkRegex + ".*ZGO::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12})\\sReply-To:\\s(zs[a-z0-9]{76}).*" + let p = + mkRegex + ".*ZGOp::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12}).*" + let k = map zToZGoTx (filter (isRelevant r) txs) + mapM_ (access pipe master (c_dbName config) . upsertZGoTx "txs") k + let j = map zToZGoTx (filter (isRelevant p) txs) + mapM_ (access pipe master (c_dbName config) . upsertPayment) j + Left e -> do + putStrLn $ "Error scanning node transactions: " ++ T.unpack e + return () + +-- | Function to filter transactions +isRelevant :: Text.Regex.Regex -> ZcashTx -> Bool +isRelevant re t + | zconfirmations t < 10 && (matchTest re . T.unpack . zmemo) t = True + | otherwise = False + +-- | Function to scan loaded viewing keys for payments +scanPayments :: Config -> Pipe -> IO () +scanPayments config pipe = do + shops <- listAddresses (c_nodeUser config) (c_nodePwd config) + mapM_ (findPaidOrders config pipe) shops + where + findPaidOrders :: Config -> Pipe -> ZcashAddress -> IO () + findPaidOrders c p z = do + paidTxs <- listTxs (c_nodeUser c) (c_nodePwd c) (addy z) 5 + case paidTxs of + Right txs -> do + let r = mkRegex ".*ZGo Order::([0-9a-fA-F]{24}).*" + let k = filter (isRelevant r) txs + let j = map (getOrderId r) k + mapM_ (access p master (c_dbName config) . markOrderPaid) j + Left e -> putStrLn $ T.unpack e + getOrderId :: Text.Regex.Regex -> ZcashTx -> (String, Double) + getOrderId re t = do + let reg = matchAllText re (T.unpack $ zmemo t) + if not (null reg) + then (fst $ head reg ! 1, zamount t) + else ("", 0) + +-- | RPC methods +-- | List addresses with viewing keys loaded +listAddresses :: BS.ByteString -> BS.ByteString -> IO [ZcashAddress] +listAddresses user pwd = do + response <- makeZcashCall user pwd "listaddresses" [] + let rpcResp = getResponseBody response + case rpcResp of + Nothing -> fail "Couldn't parse node response" + Just res -> do + let addys = fromMaybe [] $ result res :: [AddressGroup] + let addList = concatMap getAddresses addys + return $ filter (\a -> source a == ImportedWatchOnly) addList + +-- | Helper function to extract addresses from AddressGroups +getAddresses :: AddressGroup -> [ZcashAddress] +getAddresses ag = agtransparent ag <> agsapling ag <> agunified ag -- | Function to generate users from login txs -updateLogins :: - BS.ByteString -> BS.ByteString -> T.Text -> Pipe -> T.Text -> IO () -updateLogins nodeUser nodePwd addr pipe db = do +updateLogins :: Pipe -> Config -> IO () +updateLogins pipe config = do + let db = c_dbName config + let nodeUser = c_nodeUser config + let nodePwd = c_nodePwd config + let addr = c_nodeAddress config results <- access pipe diff --git a/stack.yaml b/stack.yaml index 25fd3fd..90dff48 100644 --- a/stack.yaml +++ b/stack.yaml @@ -41,7 +41,9 @@ packages: # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a # # extra-deps: [] - +extra-deps: + - git: https://github.com/reach-sh/haskell-hexstring.git + commit: 085c16fb21b9f856a435a3faab980e7e0b319341 # Override default flag values for local packages and extra-deps # flags: {} diff --git a/stack.yaml.lock b/stack.yaml.lock index cd82386..fa7fbb1 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -3,7 +3,18 @@ # For more information, please see the documentation at: # https://docs.haskellstack.org/en/stable/lock_files -packages: [] +packages: +- completed: + name: hexstring + version: 0.11.1 + git: https://github.com/reach-sh/haskell-hexstring.git + pantry-tree: + size: 687 + sha256: 9ecf67856f59dfb382b283eceb42e4fc1865935d1a7e59111556ed381c6a2ffd + commit: 085c16fb21b9f856a435a3faab980e7e0b319341 + original: + git: https://github.com/reach-sh/haskell-hexstring.git + commit: 085c16fb21b9f856a435a3faab980e7e0b319341 snapshots: - completed: size: 618683 diff --git a/test/Spec.hs b/test/Spec.hs index 87c7470..55c32f5 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,12 +2,12 @@ module Spec where +import Config import Control.Concurrent (forkIO, threadDelay) import Control.Exception (bracket) import Control.Monad.IO.Class import qualified Data.Aeson as A import qualified Data.ByteString as B -import Data.Char (isAscii) import Data.Configurator import Data.Either import Data.Maybe @@ -39,12 +39,7 @@ import ZGoTx main :: IO () main = do putStrLn "Reading config..." - config <- load ["zgo.cfg"] - let dbName = "test" - nodeAddress <- require config "nodeAddress" - nodeUser <- require config "nodeUser" - nodePwd <- require config "nodePassword" - passkey <- secureMemFromByteString <$> require config "passkey" + loadedConfig <- loadZGoConfig "zgotest.cfg" hspec $ do describe "Helper functions" $ do describe "decodeHexText" $ do @@ -54,7 +49,7 @@ main = do "ZGO::5d3d4494-51c0-432d-8495-050419957aea\nReply-To:\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" describe "hex strings" $ do prop "encoding and decoding are inverse" $ \x -> - (decodeHexText . encodeHexText) (filter isAscii x) == filter isAscii x + (decodeHexText . encodeHexText) x == x describe "zToZGoTx" $ do it "converts zcash tx to ZGo tx" $ do let t = @@ -81,7 +76,7 @@ main = do it "should give a 7 digit" $ do length (T.unpack (unsafePerformIO generatePin)) `shouldBe` 7 describe "API endpoints" $ do - beforeAll_ (startAPI dbName passkey nodeAddress nodeUser nodePwd) $ do + beforeAll_ (startAPI loadedConfig) $ do describe "Price endpoint" $ do it "returns a price for an existing currency" $ do req <- testGet "/api/price" [("currency", Just "usd")] @@ -158,7 +153,7 @@ main = do it "get order with wrong id" $ do req <- testGet "/api/order/6273hrb" [] res <- httpLBS req - getResponseStatus res `shouldBe` unprocessableEntity422 + getResponseStatus res `shouldBe` noContent204 it "get all orders for owner" $ do req <- testGet "/api/allorders" [("address", Just "Zaddy")] res <- httpJSON req @@ -238,11 +233,38 @@ main = do access p master "test" $ findOne (select ["_id" =: userId] "users") isNothing q `shouldBe` True + describe "Orders" $ do + it "marked as paid" $ \p -> do + myTs <- liftIO getCurrentTime + let myOrder = + ZGoOrder + (Just (read "627ab3ea2b05a76be3000001")) + "Zaddy" + "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd" + myTs + False + "usd" + 102.0 + 0 + 0 + [] + False + let ordTest = val myOrder + case ordTest of + Doc oT -> access p master "test" (insert_ "orders" oT) + _ <- + access p master "test" $ markOrderPaid "627ab3ea2b05a76be3000001" + o <- + access p master "test" $ findOrderById "627ab3ea2b05a76be3000001" + let o1 = (cast' . Doc) =<< o + case o1 of + Nothing -> True `shouldBe` False + Just o2 -> qpaid o2 `shouldBe` True describe "Zcash transactions" $ do it "logins are added to db" $ \p -> do _ <- access p master "test" (Database.MongoDB.delete (select [] "txs")) - _ <- scanZcash nodeAddress p "test" nodeUser nodePwd + _ <- scanZcash loadedConfig p threadDelay 1000000 t <- access p master "test" $ findOne (select [] "txs") let s = parseZGoTxBson =<< t @@ -255,7 +277,7 @@ main = do master "test" (Database.MongoDB.delete (select [] "payments")) - _ <- scanZcash nodeAddress p "test" nodeUser nodePwd + _ <- scanZcash loadedConfig p threadDelay 1000000 t <- access p master "test" $ findOne (select [] "payments") let s = (cast' . Doc) =<< t @@ -346,7 +368,7 @@ main = do "test" (Database.MongoDB.delete (select [] "users")) _ <- access p master "test" (insert_ "txs" (encodeZGoTxBson myTx)) - _ <- updateLogins nodeUser nodePwd nodeAddress p "test" + _ <- updateLogins p loadedConfig threadDelay 1000000 t <- access p master "test" $ findOne (select [] "users") case t of @@ -407,7 +429,9 @@ testOwnerAdd o = req <- run $ testPostJson "/api/owner" (A.object ["payload" A..= A.toJSON o]) --`debug` show o res <- httpLBS req - assert $ getResponseStatus res == created201 + if opayconf o + then assert $ getResponseStatus res == internalServerError500 + else assert $ getResponseStatus res == created201 testOrderAdd :: ZGoOrder -> Property testOrderAdd o = @@ -439,13 +463,12 @@ closeDbConnection = close handleDb :: (Pipe -> Expectation) -> IO () handleDb = bracket openDbConnection closeDbConnection -startAPI :: - T.Text -> SecureMem -> T.Text -> B.ByteString -> B.ByteString -> IO () -startAPI db passkey nodeAddress nodeUser nodePwd = do +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") - let appRoutes = routes pipe db passkey nodeAddress nodeUser nodePwd + let appRoutes = routes pipe config _ <- forkIO (scotty 3000 appRoutes) let myUser = User @@ -493,6 +516,8 @@ startAPI db passkey nodeAddress nodeUser nodePwd = do False False (UTCTime (fromGregorian 2022 4 16) (secondsToDiffTime 0)) + False + "" _ <- access pipe master "test" (Database.MongoDB.delete (select [] "owners")) let o = val myOwner case o of @@ -577,8 +602,11 @@ instance Arbitrary Owner where paid <- arbitrary zats <- arbitrary inv <- arbitrary + exp <- arbitrary + payconf <- arbitrary --exp <- arbitrary - Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv <$> 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 <$> + arbitrary instance Arbitrary Item where arbitrary = do diff --git a/zgo-backend.cabal b/zgo-backend.cabal index cbc8fb2..f77af56 100644 --- a/zgo-backend.cabal +++ b/zgo-backend.cabal @@ -26,6 +26,7 @@ source-repository head library exposed-modules: + Config Item Order Owner @@ -44,6 +45,8 @@ library , base >=4.7 && <5 , bson , bytestring + , configurator + , hexstring , http-conduit , http-types , mongoDB @@ -51,6 +54,7 @@ library , random , regex-base , regex-compat + , scientific , scotty , securemem , text diff --git a/zgotest.cfg b/zgotest.cfg new file mode 100644 index 0000000..ca65231 --- /dev/null +++ b/zgotest.cfg @@ -0,0 +1,12 @@ +passkey = "superSecret" +nodeAddress = "zs1xnpqd2tae9d95f8fhe4l0q7j44a5vf993m0pcnnvr56uqr4lgqlamesk5v4c5rhtvywc6lvlduy" +dbHost = "127.0.0.1" +dbName = "test" +dbUser = "zgo" +dbPassword = "zcashrules" +nodeUser = "zecwallet" +nodePassword = "rdsxlun6v4a" +port = 3000 +tls = false +certificate = "/path/to/cert.pem" +key = "/path/to/key.pem"