Merge branch 'dev'

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`
 

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"]
+  loadedConfig <- loadZGoConfig "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"
   let myTlsSettings =
-        if useTls
+        if c_useTls loadedConfig
-          then Just $ tlsSettings cert key
+          then Just $
+               tlsSettings (c_certificate loadedConfig) (c_key loadedConfig)
           else Nothing
   putStrLn "Starting Server..."
-  pipe <- connect $ host dbHost
+  pipe <- connect $ host (c_dbHost loadedConfig)
-  j <- access pipe master dbName (auth dbUser dbPassword)
+  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 60 (checkZcashPrices pipe (c_dbName loadedConfig)))
-  _ <-
+  _ <- forkIO (setInterval 75 (scanZcash loadedConfig pipe))
-    forkIO (setInterval 75 (scanZcash nodeAddress pipe dbName nodeUser nodePwd))
+  _ <- forkIO (setInterval 90 (scanPayments loadedConfig pipe))
-  _ <- forkIO (setInterval 60 (checkPayments pipe dbName))
+  _ <- forkIO (setInterval 60 (checkPayments pipe (c_dbName loadedConfig)))
-  _ <- forkIO (setInterval 60 (expireOwners pipe dbName))
+  _ <- forkIO (setInterval 60 (expireOwners pipe (c_dbName loadedConfig)))
-  _ <-
+  _ <- forkIO (setInterval 60 (updateLogins pipe loadedConfig))
-    forkIO
+  let appRoutes = routes pipe loadedConfig
-      (setInterval 60 (updateLogins nodeUser nodePwd nodeAddress pipe dbName))
-  let appRoutes = routes pipe dbName passkey nodeAddress nodeUser nodePwd
   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

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:

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

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

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)

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

src/User.hs

@@ -99,9 +99,9 @@ validateUser session =
     (select ["session" =: session] "users")
     ["$set" =: ["validated" =: True]]
 
-generatePin :: IO T.Text
+generatePin :: Int -> IO T.Text
-generatePin = do
+generatePin s = do
-  g <- newStdGen
+  let g = mkStdGen s
   pure $
     T.pack (padLeft (show . head $ randomRs (1 :: Integer, 10000000) g) '0' 7)
 

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 :: String -> T.Text
-decodeHexText hexText
+decodeHexText h = E.decodeUtf8With lenientDecode $ BS.pack $ hexRead h
-  -- | chunk == "00" = decodeHexText (drop 2 hexText)
+  where
-  | null chunk = ""
+    hexRead hexText
-  | otherwise = chr (read ("0x" <> chunk)) : decodeHexText (drop 2 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.Text -> String
-encodeHexText t = mconcat (map padHex t)
+encodeHexText t = T.unpack . toText . fromBytes $ E.encodeUtf8 t
-  where
-    padHex x =
-      if ord x < 16
-        then "0" ++ (showHex . ord) x ""
-        else showHex (ord x) ""
 
 -- 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)
+      let nAddy = T.pack (fst $ head reg ! 2)
-      ZGoTx Nothing addy sess conf bt a t m
+      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 ::
+routes :: Pipe -> Config -> ScottyM ()
-     Pipe
+routes pipe config = do
-  -> T.Text
+  let run = access pipe master (c_dbName config)
-  -> SecureMem
+  let passkey = c_passkey config
-  -> T.Text
+  let nodeUser = c_nodeUser config
-  -> BS.ByteString
+  let nodePwd = c_nodePwd config
-  -> BS.ByteString
+  let nodeAddress = c_nodeAddress config
-  -> ScottyM ()
-routes pipe db passkey nodeAddress nodeUser nodePwd = do
-  let run = access pipe master db
   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)
+    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
+-- | Function to search for transactions for an address
-scanZcash :: T.Text -> Pipe -> T.Text -> BS.ByteString -> BS.ByteString -> IO ()
+listTxs ::
-scanZcash addr pipe db nodeUser nodePwd = do
+     BS.ByteString
+  -> BS.ByteString
+  -> T.Text
+  -> Integer
+  -> IO (Either T.Text [ZcashTx])
+listTxs user pwd a confs = do
   res <-
+    liftIO $
     makeZcashCall
-      nodeUser
+      user
-      nodePwd
+      pwd
       "z_listreceivedbyaddress"
-      [Data.Aeson.String addr]
+      [Data.Aeson.String a, Data.Aeson.Number $ Scientific.scientific confs 0]
-  let txs =
+  let content = getResponseBody res :: RpcResponse [ZcashTx]
-        filter (not . zchange) $
+  case err content of
-        result (getResponseBody res :: RpcResponse [ZcashTx])
+    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 (matchTest r . T.unpack . zmemo) txs)
+      let k = map zToZGoTx (filter (isRelevant r) txs)
-  mapM_ (access pipe master db . upsertZGoTx "txs") k
+      mapM_ (access pipe master (c_dbName config) . upsertZGoTx "txs") k
-  let j = map zToZGoTx (filter (matchTest p . T.unpack . zmemo) txs)
+      let j = map zToZGoTx (filter (isRelevant p) txs)
-  mapM_ (access pipe master db . upsertPayment) j
+      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 ::
+updateLogins :: Pipe -> Config -> IO ()
-     BS.ByteString -> BS.ByteString -> T.Text -> Pipe -> T.Text -> IO ()
+updateLogins pipe config = do
-updateLogins nodeUser nodePwd addr pipe db = do
+  let db = c_dbName config
+  let nodeUser = c_nodeUser config
+  let nodePwd = c_nodePwd config
+  let addr = c_nodeAddress config
   results <-
     access
       pipe

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: {}
 

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

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"]
+  loadedConfig <- loadZGoConfig "zgotest.cfg"
-  let dbName = "test"
-  nodeAddress <- require config "nodeAddress"
-  nodeUser <- require config "nodeUser"
-  nodePwd <- require config "nodePassword"
-  passkey <- secureMemFromByteString <$> require config "passkey"
   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 ::
+startAPI :: Config -> IO ()
-     T.Text -> SecureMem -> T.Text -> B.ByteString -> B.ByteString -> IO ()
+startAPI config = do
-startAPI db passkey nodeAddress nodeUser nodePwd = 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

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

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"