Correct block recording

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

src/Owner.hs

@@ -420,8 +420,7 @@ findExpiringOwners now =
 
 findWithKeys :: Action IO [Document]
 findWithKeys =
-  rest =<<
+  rest =<< find (select ["paid" =: True, "payconf" =: True] "owners")
-  find (select ["paid" =: True, "invoices" =: True, "payconf" =: True] "owners")
 
 removePro :: T.Text -> Action IO ()
 removePro o =

src/ZGoBackend.hs

@@ -52,6 +52,7 @@ import Numeric
 import Order
 import Owner
 import Payment
+import System.IO
 import System.IO.Unsafe
 import System.Random
 import Test.QuickCheck
@@ -69,6 +70,7 @@ import ZcashHaskell.Orchard
 import ZcashHaskell.Sapling
 import ZcashHaskell.Types
   ( BlockResponse(..)
+  , DecodedNote(..)
   , RawData(..)
   , RawTxResponse(..)
   , RpcCall(..)
@@ -371,12 +373,7 @@ listCountries :: Action IO [Document]
 listCountries = rest =<< find (select [] "countries")
 
 sendPin ::
-     BS.ByteString
+     BS.ByteString -> BS.ByteString -> T.Text -> T.Text -> T.Text -> IO String
-  -> BS.ByteString
-  -> T.Text
-  -> T.Text
-  -> T.Text
-  -> Action IO String
 sendPin nodeUser nodePwd nodeAddress addr pin = do
   let pd =
         [ Data.Aeson.String nodeAddress
@@ -388,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
@@ -413,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 $
@@ -1175,37 +1228,56 @@ routes pipe config = do
         case cast' . Doc =<< u of
           Nothing -> status unauthorized401
           Just u' -> do
-            if isValidSaplingViewingKey qBytes
+            if isValidSaplingViewingKey $ C.pack q
-              then if matchSaplingAddress
+              then do
-                        qBytes
+                if matchSaplingAddress
-                        (bytes . decodeBech32 . C.pack . T.unpack $ uaddress u')
+                     qBytes
-                     then do
+                     (bytes . decodeBech32 . C.pack . T.unpack $ uaddress u')
-                       owner <- liftAndCatchIO $ run (findOwner $ uaddress u')
+                  then do
-                       case cast' . Doc =<< owner of
+                    owner <- liftAndCatchIO $ run (findOwner $ uaddress u')
-                         Nothing -> status badRequest400
+                    case cast' . Doc =<< owner of
-                         Just o' -> do
+                      Nothing -> status badRequest400
-                           unless (oviewkey o' /= "") $ do
+                      Just o' -> do
-                             vkInfo <-
+                        unless (oviewkey o' /= "") $ do
-                               liftAndCatchIO $
+                          liftAndCatchIO $ run (upsertViewingKey o' q)
-                               makeZcashCall
+                          status created201
-                                 nodeUser
+                  else status forbidden403
-                                 nodePwd
+              else case decodeUfvk (C.pack q) of
-                                 "z_importviewingkey"
+                     Nothing -> status badRequest400
-                                 [ Data.Aeson.String (T.strip . T.pack $ q)
+                     Just fvk -> do
-                                 , "no"
+                       if isValidUnifiedAddress $
-                                 ] -- TODO: Remove this call to the node
+                          C.pack . T.unpack $ uaddress u'
-                             let content =
+                         then do
-                                   getResponseBody vkInfo :: RpcResponse Object
+                           if matchOrchardAddress
-                             if isNothing (err content)
+                                (C.pack q)
-                               then do
+                                (C.pack . T.unpack $ uaddress u')
-                                 _ <-
+                             then do
-                                   liftAndCatchIO $ run (upsertViewingKey o' q)
+                               owner <-
-                                 status created201
+                                 liftAndCatchIO $ run (findOwner $ uaddress u')
-                               else do
+                               case cast' . Doc =<< owner of
-                                 text $ L.pack . show $ err content
+                                 Nothing -> status badRequest400
-                                 status badRequest400
+                                 Just o' -> do
-                     else status forbidden403
+                                   unless (oviewkey o' /= "") $ do
-              else status badRequest400 -- TODO: add Unified VK support
+                                     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"
@@ -1803,9 +1875,14 @@ generateToken = do
   runCryptoRNGT rngState $ randomString 24 "abcdef0123456789"
 
 getBlockInfo ::
-     BS.ByteString -> BS.ByteString -> SC.Scientific -> IO (Maybe BlockResponse)
+     BS.ByteString -> BS.ByteString -> T.Text -> IO (Maybe BlockResponse)
 getBlockInfo nodeUser nodePwd bh = do
-  blockInfo <- makeZcashCall nodeUser nodePwd "getblock" [Number bh]
+  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
@@ -1813,38 +1890,61 @@ getBlockInfo nodeUser nodePwd bh = do
       print $ err content
       return Nothing
 
-scanTxNative :: Pipe -> T.Text -> BS.ByteString -> BS.ByteString -> IO ()
+scanTxNative :: Config -> Pipe -> IO ()
-scanTxNative pipe db nodeUser nodePwd = do
+scanTxNative config pipe = do
+  let db = c_dbName config
   keyOwnerList <- access pipe master db findWithKeys
   unless (null keyOwnerList) $ do
-    let ownerList = cast' . Doc <$> keyOwnerList
+    let nodeUser = c_nodeUser config
-    let keyList = map (maybe "" oviewkey) ownerList
+    let nodePwd = c_nodePwd config
+    let ownerList = mapMaybe (cast' . Doc) keyOwnerList
     lastBlockData <- access pipe master db findBlock
-    latestBlock <- getBlockInfo nodeUser nodePwd (SC.scientific (-1) 0)
+    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 . fromInteger)
+                (getBlockInfo nodeUser nodePwd . T.pack . show)
-                [2220000 .. (bl_height lB)]
+                [(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
-            mapM_ (checkTx filteredTxList) keyList
+            print "checking txs against keys..."
+            mapM_ (checkTx filteredTxList) ownerList
+            access pipe master (c_dbName config) $
+              upsertBlock (last $ catMaybes filteredBlockList)
           Just lastBlock -> do
-            let blockList' = [(bl_height lastBlock + 1) .. (bl_height lB)]
+            blockList' <-
-            print blockList'
+              mapM
-    print keyList
+                (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_shieldedOutputs t)) ||
       not (null (maybe [] rt_orchardActions t))
     extractTxs :: Maybe BlockResponse -> [T.Text]
     extractTxs = maybe [] bl_txs
@@ -1856,39 +1956,145 @@ scanTxNative pipe db nodeUser nodePwd = do
           nodeUser
           nodePwd
           "getrawtransaction"
-          [Data.Aeson.String txid]
+          [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] -> T.Text -> IO ()
+    checkTx :: [RawTxResponse] -> Owner -> IO ()
-    checkTx txList k = do
+    checkTx txList' k = do
-      if isValidSaplingViewingKey (E.encodeUtf8 k)
+      let sOutList = concatMap rt_shieldedOutputs txList'
+      if isValidSaplingViewingKey (E.encodeUtf8 $ oviewkey k)
         then do
-          let decodedTxList =
+          print "decoding Sapling tx"
-                map
+          let decodedSapList' = concatMap (decodeSaplingTx $ oviewkey k) txList'
-                  (decodeSaplingOutput (E.encodeUtf8 k))
+          let zList = catMaybes decodedSapList'
-                  (concatMap
+          mapM_ (recordPayment pipe (c_dbName config) (oaddress k)) zList
-                     rt_shieldedOutputs
-                     (filter (\x -> rt_shieldedOutputs x /= []) txList))
-          print decodedTxList
         else do
-          let vk = decodeUfvk $ E.encodeUtf8 k
+          let vk = decodeUfvk $ E.encodeUtf8 $ oviewkey k
           case vk of
             Nothing -> print "Not a valid key"
             Just v -> do
               let decodedSapList =
-                    map
+                    concatMap (decodeUnifiedSaplingTx (s_key v)) txList'
-                      (decodeSaplingOutput (s_key v))
+              let zList' = catMaybes decodedSapList
-                      (concatMap rt_shieldedOutputs txList)
+              mapM_ (recordPayment pipe (c_dbName config) (oaddress k)) zList'
-              print decodedSapList
+              let decodedOrchList = concatMap (decodeUnifiedOrchardTx v) txList'
-              let decodedOrchList =
+              let oList = catMaybes decodedOrchList
-                    map
+              mapM_ (recordPayment pipe (c_dbName config) (oaddress k)) oList
-                      (decryptOrchardAction v)
+    decodeSaplingTx :: T.Text -> RawTxResponse -> [Maybe ZcashTx]
-                      (concatMap rt_orchardActions txList)
+    decodeSaplingTx k t =
-              print decodedOrchList
+      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
 

src/ZGoTx.hs

@@ -105,6 +105,7 @@ 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
@@ -112,6 +113,7 @@ data MemoToken
   | PayMsg !U.UUID
   | Address !T.Text
   | Msg !T.Text
+  | OrderId !T.Text
   deriving (Show, Eq)
 
 type Parser = Parsec Void T.Text
@@ -146,6 +148,12 @@ pUnifiedAddress = do
     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
   msg <-
@@ -157,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
 
@@ -182,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) &&

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: d78c269d96fe7d8a626cf701b8051c40f251e232
+    commit: 1d558fc646a7758d60a721124812070de222c2e1
   - git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git
     commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05
   - git: https://github.com/well-typed/borsh.git

stack.yaml.lock

@@ -16,15 +16,15 @@ packages:
     commit: 085c16fb21b9f856a435a3faab980e7e0b319341
     git: https://github.com/reach-sh/haskell-hexstring.git
 - completed:
-    commit: d78c269d96fe7d8a626cf701b8051c40f251e232
+    commit: 1d558fc646a7758d60a721124812070de222c2e1
     git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git
     name: zcash-haskell
     pantry-tree:
-      sha256: 69201a27ac966be478ef0b8e3fa8e8bf5cbcc67a58cd254326545eb4f3e93569
+      sha256: eab3c6817bb3cb5738725824d16eb023cb2967ef3bbaa8f8252524602f606dbb
       size: 1229
     version: 0.2.0
   original:
-    commit: d78c269d96fe7d8a626cf701b8051c40f251e232
+    commit: 1d558fc646a7758d60a721124812070de222c2e1
     git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git
 - completed:
     commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05

test/Spec.hs

@@ -101,8 +101,9 @@ main = do
           case m of
             Left e -> putStrLn $ errorBundlePretty e
             Right m' ->
-              m_session m' `shouldBe`
+              m_address m' `shouldBe`
-              U.fromString "5d3d4494-51c0-432d-8495-050419957aea"
+              Just
+                "u17n7hpwaujyq7ux8f9jpyymtnk5urw7pyrf60smp5mawy7jgz325hfvz3jn3zsfya8yxryf9q7ldk8nu8df0emra5wne28zq9d9nm2pu4x6qwjha565av9aze0xgujgslz74ufkj0c0cylqwjyrh9msjfh7jzal6d3qzrnhkkqy3pqm8j63y07jxj7txqeac982778rmt64f32aum94x"
         it "parse YWallet memo - Orchard" $ do
           let m =
                 runParser
@@ -112,8 +113,9 @@ main = do
           case m of
             Left e -> putStrLn $ errorBundlePretty e
             Right m' ->
-              m_session m' `shouldBe`
+              m_address m' `shouldBe`
-              U.fromString "ad8477d3-4fdd-4c97-90b2-76630b5f77e1"
+              Just
+                "u17n7hpwaujyq7ux8f9jpyymtnk5urw7pyrf60smp5mawy7jgz325hfvz3jn3zsfya8yxryf9q7ldk8nu8df0emra5wne28zq9d9nm2pu4x6qwjha565av9aze0xgujgslz74ufkj0c0cylqwjyrh9msjfh7jzal6d3qzrnhkkqy3pqm8j63y07jxj7txqeac982778rmt64f32aum94x"
         it "parse Zingo memo - Orchard" $ do
           let m =
                 runParser
@@ -123,8 +125,9 @@ main = do
           case m of
             Left e -> putStrLn $ errorBundlePretty e
             Right m' ->
-              m_session m' `shouldBe`
+              m_address m' `shouldBe`
-              U.fromString "5d3d4494-51c0-432d-8495-050419957aea"
+              Just
+                "u17n7hpwaujyq7ux8f9jpyymtnk5urw7pyrf60smp5mawy7jgz325hfvz3jn3zsfya8yxryf9q7ldk8nu8df0emra5wne28zq9d9nm2pu4x6qwjha565av9aze0xgujgslz74ufkj0c0cylqwjyrh9msjfh7jzal6d3qzrnhkkqy3pqm8j63y07jxj7txqeac982778rmt64f32aum94x"
       describe "PIN generator" $ do
         it "should give a 7 digit" $ do
           pin <- generatePin
@@ -688,6 +691,8 @@ main = do
                 "zxviews1qdjagrrpqqqqpq8es75mlu6rref0qyrstchf8dxzeygtsejwfqu8ckhwl2qj5m8am7lmupxk3vkvdjm8pawjpmesjfapvsqw96pa46c2z0kk7letrxf7mkltwz54fwpxc7kc79mm5kce3rwn5ssl009zwsra2spppwgrx25s9k5hq65f69l4jz2tjmqgy0pl49qmtaj3nudk6wglwe2hpa327hydlchtyq9av6wjd6hu68e04ahwk9a9n2kt0kj3nj99nue65awtu5cwwcpjs"
           let vk2 =
                 "zxviews1qdjagrrpqqqqpq8es75mlufakef0qyrstchf8dxzeygtsejwfqu8ckhwl2qj5m8am7lmupxk3vkvdjm8pawjpmesjfapvsqw96pa46c2z0kk7letrxf7mkltwz54fwpxc7kc79mm5kce3rwn5ssl009zwsra2spppwgrx25s9k5hq65f69l4jz2tjmqgy0pl49qmtaj3nudk6wglwe2hpa327hydlchtyq9av6wjd6hu68e04ahwk9a9n2kt0kj3nj99nue65awtu5cwwcpjs"
+          let vk3 =
+                "uview1u833rp8yykd7h4druwht6xp6k8krle45fx8hqsw6vzw63n24atxpcatws82z092kryazuu6d7rayyut8m36wm4wpjy2z8r9hj48fx5pf49gw4sjrq8503qpz3vqj5hg0vg9vsqeasg5qjuyh94uyfm7v76udqcm2m0wfc25hcyqswcn56xxduq3xkgxkr0l73cjy88fdvf90eq5fda9g6x7yv7d0uckpevxg6540wc76xrc4axxvlt03ptaa2a0rektglmdy68656f3uzcdgqqyu0t7wk5cvwghyyvgqc0rp3vgu5ye4nd236ml57rjh083a2755qemf6dk6pw0qrnfm7246s8eg2hhzkzpf9h73chhng7xhmyem2sjh8rs2m9nhfcslsgenm"
           it "returns 401 with bad session" $ do
             req <-
               testPostJson "/api/ownervk" $
@@ -728,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)]
@@ -738,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
@@ -1176,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
@@ -1233,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
@@ -1242,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 =