CHANGELOG.md

@@ -6,23 +6,9 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
 
 ## [Unreleased]
 
-### Added
+## Changed
 
-- Parser for Unified Addresses that validates the address
-- Tests for UA parsing from wallets
-- Function to scan new transactions using known viewing keys
-- Function to identify the owners and VKs needed for tx scans
-
-### Changed
-
-- Order endpoint updated to ensure orders belong to shop before adding to DB.
 - MongoDB driver updated to support MongoDB 6.
-- Full validation of Sapling addresses to parser.
-
-### Removed
-
-- `makeZcashCall` function moved to the generic `zcash-haskell` library.
-- `RpcResponse`, `RpcCall` types moved to the generic `zcash-haskell` library.
 
 ## [1.7.0]
 

app/Tasks.hs

@@ -23,8 +23,7 @@ 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

@@ -14,7 +14,8 @@ import Database.MongoDB
 import GHC.Generics
 
 -- | Type to represent a ZGo shop owner/business
-data Owner = Owner
+data Owner =
+  Owner
     { o_id :: Maybe ObjectId
     , oaddress :: T.Text
     , oname :: T.Text
@@ -40,7 +41,8 @@ data Owner = Owner
     , opayconf :: Bool
     , oviewkey :: T.Text
     , ocrmToken :: T.Text
-  } deriving (Eq, Show, Generic, Typeable)
+    }
+  deriving (Eq, Show, Generic, Typeable)
 
 instance ToJSON Owner where
   toJSON (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv eTs pc vk cT) =
@@ -274,7 +276,8 @@ instance Val Owner where
           ]
 
 -- | Type to represent informational data for Owners from UI
-data OwnerData = OwnerData
+data OwnerData =
+  OwnerData
     { od_first :: T.Text
     , od_last :: T.Text
     , od_name :: T.Text
@@ -286,7 +289,8 @@ data OwnerData = OwnerData
     , od_email :: T.Text
     , od_website :: T.Text
     , od_phone :: T.Text
-  } deriving (Eq, Show, Generic)
+    }
+  deriving (Eq, Show, Generic)
 
 instance FromJSON OwnerData where
   parseJSON =
@@ -304,7 +308,8 @@ instance FromJSON OwnerData where
       ph <- obj .: "phone"
       pure $ OwnerData f l n s c st p co e w ph
 
-data OwnerSettings = OwnerSettings
+data OwnerSettings =
+  OwnerSettings
     { os_id :: Maybe ObjectId
     , os_address :: T.Text
     , os_name :: T.Text
@@ -320,7 +325,8 @@ data OwnerSettings = OwnerSettings
     , os_payconf :: Bool
     , os_crmToken :: T.Text
     , os_viewKey :: T.Text
-  } deriving (Eq, Show, Generic)
+    }
+  deriving (Eq, Show, Generic)
 
 instance FromJSON OwnerSettings where
   parseJSON =
@@ -418,10 +424,6 @@ findExpiringOwners now =
        ["paid" =: True, "expiration" =: ["$lte" =: addUTCTime 172800 now]]
        "owners")
 
-findWithKeys :: Action IO [Document]
-findWithKeys =
-  rest =<< find (select ["paid" =: True, "payconf" =: True] "owners")
-
 removePro :: T.Text -> Action IO ()
 removePro o =
   modify (select ["address" =: o] "owners") ["$set" =: ["invoices" =: False]]
@@ -448,12 +450,14 @@ upsertViewingKey o vk =
   modify (select ["_id" =: o_id o] "owners") ["$set" =: ["viewKey" =: vk]]
 
 -- | Type for a pro session
-data ZGoProSession = ZGoProSession
+data ZGoProSession =
+  ZGoProSession
     { ps_id :: Maybe ObjectId
     , psaddress :: T.Text
     , psexpiration :: UTCTime
     , psclosed :: Bool
-  } deriving (Eq, Show)
+    }
+  deriving (Eq, Show)
 
 instance Val ZGoProSession where
   cast' (Doc d) = do

src/ZGoBackend.hs

@@ -25,7 +25,7 @@ import Data.Char
 import qualified Data.HashMap.Strict as HM
 import Data.HexString
 import Data.Maybe
-import qualified Data.Scientific as SC
+import qualified Data.Scientific as Scientific
 import Data.SecureMem
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as E
@@ -37,8 +37,9 @@ import Data.Time.Format
 import Data.Typeable
 import qualified Data.UUID as U
 import qualified Data.Vector as V
+import Data.Vector.Internal.Check (doChecks)
 import Data.Word
-import Database.MongoDB hiding (Order, lookup)
+import Database.MongoDB hiding (Order)
 import Debug.Trace
 import GHC.Generics
 import Item
@@ -52,7 +53,6 @@ import Numeric
 import Order
 import Owner
 import Payment
-import System.IO
 import System.IO.Unsafe
 import System.Random
 import Test.QuickCheck
@@ -66,21 +66,47 @@ import Web.Scotty
 import WooCommerce
 import Xero
 import ZGoTx
-import ZcashHaskell.Orchard
 import ZcashHaskell.Sapling
-import ZcashHaskell.Types
+import ZcashHaskell.Types (RawData(..))
-  ( BlockResponse(..)
+import ZcashHaskell.Utils (decodeBech32)
-  , DecodedNote(..)
-  , RawData(..)
-  , RawTxResponse(..)
-  , RpcCall(..)
-  , RpcError(..)
-  , RpcResponse(..)
-  , UnifiedFullViewingKey(..)
-  )
-import ZcashHaskell.Utils (decodeBech32, makeZcashCall)
 
 -- Models for API objects
+-- | A type to model Zcash RPC calls
+data RpcCall = RpcCall
+  { jsonrpc :: T.Text
+  , callId :: T.Text
+  , method :: T.Text
+  , parameters :: [Data.Aeson.Value]
+  } deriving (Show, Generic)
+
+instance ToJSON RpcCall where
+  toJSON (RpcCall j c m p) =
+    object ["jsonrpc" .= j, "id" .= c, "method" .= m, "params" .= p]
+
+-- | A type to model the response of the Zcash RPC
+data RpcResponse r = MakeRpcResponse
+  { err :: Maybe RpcError
+  , respId :: T.Text
+  , result :: Maybe r
+  } deriving (Show, Generic, ToJSON)
+
+instance (FromJSON r) => FromJSON (RpcResponse r) where
+  parseJSON (Object obj) =
+    MakeRpcResponse <$> obj .: "error" <*> obj .: "id" <*> obj .: "result"
+  parseJSON _ = mzero
+
+data RpcError = RpcError
+  { ecode :: Double
+  , emessage :: T.Text
+  } deriving (Show, Generic, ToJSON)
+
+instance FromJSON RpcError where
+  parseJSON =
+    withObject "RpcError" $ \obj -> do
+      c <- obj .: "code"
+      m <- obj .: "message"
+      pure $ RpcError c m
+
 data Payload r = Payload
   { payload :: r
   } deriving (Show, Generic, ToJSON)
@@ -373,7 +399,12 @@ listCountries :: Action IO [Document]
 listCountries = rest =<< find (select [] "countries")
 
 sendPin ::
-     BS.ByteString -> BS.ByteString -> T.Text -> T.Text -> T.Text -> IO String
+     BS.ByteString
+  -> BS.ByteString
+  -> T.Text
+  -> T.Text
+  -> T.Text
+  -> Action IO String
 sendPin nodeUser nodePwd nodeAddress addr pin = do
   let pd =
         [ Data.Aeson.String nodeAddress
@@ -385,73 +416,17 @@ 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
+  r <- liftIO $ try $ makeZcashCall nodeUser nodePwd "z_sendmany" pd --  IO (Either HttpException (Response Object))
   case r of
     Right res -> do
-      let sCode = getResponseStatus (res :: Response (RpcResponse T.Text))
+      let sCode = getResponseStatus (res :: Response Object)
-      let rBody = getResponseBody res
       if sCode == ok200
-        then do
+        then return "Pin sent!"
-          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
@@ -466,7 +441,7 @@ addUser nodeUser nodePwd p db node (Just tx) = do
   isNew <- liftIO $ isUserNew p db tx
   when isNew $ do
     newPin <- liftIO generatePin
-    _ <- liftIO $ sendPin nodeUser nodePwd node (address tx) (T.pack newPin)
+    _ <- sendPin nodeUser nodePwd node (address tx) (T.pack newPin)
     let pinHash =
           BLK.hash
             [ BA.pack . BS.unpack . C.pack . T.unpack $
@@ -590,7 +565,6 @@ routes pipe config = do
   let nodeUser = c_nodeUser config
   let nodePwd = c_nodePwd config
   let nodeAddress = c_nodeAddress config
-  let dbName = c_dbName config
   middleware $
     cors $
     const $
@@ -1229,9 +1203,8 @@ routes pipe config = do
         case cast' . Doc =<< u of
           Nothing -> status unauthorized401
           Just u' -> do
-            if isValidSaplingViewingKey $ C.pack q
+            if isValidSaplingViewingKey qBytes
-              then do
+              then if matchSaplingAddress
-                if matchSaplingAddress
                         qBytes
                         (bytes . decodeBech32 . C.pack . T.unpack $ uaddress u')
                      then do
@@ -1240,45 +1213,27 @@ routes pipe config = do
                          Nothing -> status badRequest400
                          Just o' -> do
                            unless (oviewkey o' /= "") $ do
+                             vkInfo <-
+                               liftAndCatchIO $
+                               makeZcashCall
+                                 nodeUser
+                                 nodePwd
+                                 "z_importviewingkey"
+                                 [ Data.Aeson.String (T.strip . T.pack $ q)
+                                 , "no"
+                                 ]
+                             let content =
+                                   getResponseBody vkInfo :: RpcResponse Object
+                             if isNothing (err content)
+                               then do
+                                 _ <-
                                    liftAndCatchIO $ run (upsertViewingKey o' q)
                                  status created201
-                  else status forbidden403
-              else case decodeUfvk (C.pack q) of
-                     Nothing -> status badRequest400
-                     Just fvk -> do
-                       if isValidUnifiedAddress $
-                          C.pack . T.unpack $ uaddress u'
-                         then do
-                           if matchOrchardAddress
-                                (C.pack q)
-                                (C.pack . T.unpack $ uaddress u')
-                             then do
-                               owner <-
-                                 liftAndCatchIO $ run (findOwner $ uaddress u')
-                               case cast' . Doc =<< owner of
-                                 Nothing -> status badRequest400
-                                 Just o' -> do
-                                   unless (oviewkey o' /= "") $ do
-                                     liftAndCatchIO $
-                                       run (upsertViewingKey o' q)
-                                     status created201
-                             else status forbidden403
                                else do
-                           if matchSaplingAddress
+                                 text $ L.pack . show $ err content
-                                (s_key fvk)
+                                 status badRequest400
-                                (bytes . decodeBech32 . C.pack . T.unpack $
-                                 uaddress u')
-                             then do
-                               owner <-
-                                 liftAndCatchIO $ run (findOwner $ uaddress u')
-                               case cast' . Doc =<< owner of
-                                 Nothing -> status badRequest400
-                                 Just o' -> do
-                                   unless (oviewkey o' /= "") $ do
-                                     liftAndCatchIO $
-                                       run (upsertViewingKey o' q)
-                                     status created201
                      else status forbidden403
+              else status badRequest400
     --Get items associated with the given address
   get "/api/items" $ do
     session <- param "session"
@@ -1429,10 +1384,6 @@ routes pipe config = do
     case cast' . Doc =<< user of
       Nothing -> status unauthorized401
       Just u -> do
-        dbOrder <-
-          liftAndCatchIO $ run (findOrderById $ maybe "0" show (q_id q))
-        case cast' . Doc =<< dbOrder of
-          Nothing -> do
         if uaddress u == qaddress q
           then do
             if qtoken q == ""
@@ -1443,29 +1394,9 @@ routes pipe config = do
                   run (upsertOrder $ setOrderToken (T.pack t) q)
                 status created201
               else do
-                    _ <-
+                _ <- liftAndCatchIO $ run (upsertOrder q)
-                      liftAndCatchIO $ access pipe master dbName (upsertOrder q)
                 status created201
           else status forbidden403
-          Just dbO -> do
-            if qaddress q == qaddress dbO && qsession q == qsession dbO
-              then do
-                if uaddress u == qaddress q
-                  then do
-                    if qtoken q == ""
-                      then do
-                        t <- liftIO generateToken
-                        _ <-
-                          liftAndCatchIO $
-                          run (upsertOrder $ setOrderToken (T.pack t) q)
-                        status created201
-                      else do
-                        _ <-
-                          liftAndCatchIO $
-                          access pipe master dbName (upsertOrder q)
-                        status created201
-                  else status forbidden403
-              else status forbidden403
     --Delete order
   Web.Scotty.delete "/api/order/:id" $ do
     oId <- param "id"
@@ -1530,50 +1461,31 @@ routes pipe config = do
       Just tP -> do
         status ok200
         Web.Scotty.json $ toJSON (tP :: LangComponent)
-  where
-    saveOrder :: Pipe -> T.Text -> User -> ZGoOrder -> ActionM ()
-    saveOrder pipe dbName u q = do
-      if uaddress u == qaddress q
-        then do
-          if qtoken q == ""
-            then do
-              t <- liftIO generateToken
-              _ <-
-                liftAndCatchIO $
-                access
-                  pipe
-                  master
-                  dbName
-                  (upsertOrder $ setOrderToken (T.pack t) q)
-              status created201
-            else do
-              _ <- liftAndCatchIO $ access pipe master dbName (upsertOrder q)
-              status created201
-        else status forbidden403
   {-post "/api/setlang" $ do-}
     {-langComp <- jsonData-}
     {-_ <--}
       {-liftAndCatchIO $-}
       {-mapM (run . loadLangComponent) (langComp :: [LangComponent])-}
     {-status created201-}
-     {-(MonadIO m, FromJSON a)-}
-  {-=> BS.ByteString-}
-  {--> BS.ByteString-}
-  {--> T.Text-}
-  {--> [Data.Aeson.Value]-}
-  {--> m (Response a)-}
-  {-let payload =-}
-        {-RpcCall {jsonrpc = "1.0", callId = "test", method = m, parameters = p}-}
-  {-let myRequest =-}
-        {-setRequestBodyJSON payload $-}
-        {-setRequestPort 8232 $-}
-        {-setRequestBasicAuth username password $-}
-        {-setRequestMethod "POST" defaultRequest-}
-  {-httpJSON myRequest-}
 
 -- | Make a Zcash RPC call
-{-makeZcashCall ::-}
+makeZcashCall ::
-{-makeZcashCall username password m p = do-}
+     (MonadIO m, FromJSON a)
+  => BS.ByteString
+  -> BS.ByteString
+  -> T.Text
+  -> [Data.Aeson.Value]
+  -> m (Response a)
+makeZcashCall username password m p = do
+  let payload =
+        RpcCall {jsonrpc = "1.0", callId = "test", method = m, parameters = p}
+  let myRequest =
+        setRequestBodyJSON payload $
+        setRequestPort 8232 $
+        setRequestBasicAuth username password $
+        setRequestMethod "POST" defaultRequest
+  httpJSON myRequest
+
 -- |Timer for repeating actions
 setInterval :: Int -> IO () -> IO ()
 setInterval secs func = do
@@ -1615,7 +1527,7 @@ listTxs user pwd a confs = do
       user
       pwd
       "z_listreceivedbyaddress"
-      [Data.Aeson.String a, Data.Aeson.Number $ SC.scientific confs 0] :: IO
+      [Data.Aeson.String a, Data.Aeson.Number $ Scientific.scientific confs 0] :: IO
       (Either HttpException (Response (RpcResponse [ZcashTx])))
   case res of
     Right txList -> do
@@ -1813,7 +1725,7 @@ payOwner p d x =
             markOwnerPaid :: Pipe -> T.Text -> Payment -> IO ()
             markOwnerPaid pipe db pmt = do
               user <- access pipe master db (findUser $ psession pmt)
-              -- print pmt
+              print pmt
               let parsedUser = parseUserBson =<< user
               let zaddy = maybe "" uaddress parsedUser
               owner <- access pipe master db $ findOwner zaddy
@@ -1919,253 +1831,4 @@ generateToken = do
   rngState <- newCryptoRNGState
   runCryptoRNGT rngState $ randomString 24 "abcdef0123456789"
 
-getBlockInfo ::
-     BS.ByteString -> BS.ByteString -> T.Text -> IO (Maybe BlockResponse)
-getBlockInfo nodeUser nodePwd bh = do
-  blockInfo <-
-    makeZcashCall
-      nodeUser
-      nodePwd
-      "getblock"
-      [Data.Aeson.String bh, Number $ SC.scientific 1 0]
-  let content = getResponseBody blockInfo :: RpcResponse BlockResponse
-  if isNothing (err content)
-    then return $ result content
-    else do
-      print $ err content
-      return Nothing
-
-scanTxNative :: Config -> Pipe -> IO ()
-scanTxNative config pipe = do
-  let db = c_dbName config
-  keyOwnerList <- access pipe master db findWithKeys
-  unless (null keyOwnerList) $ do
-    let nodeUser = c_nodeUser config
-    let nodePwd = c_nodePwd config
-    let ownerList = mapMaybe (cast' . Doc) keyOwnerList
-    lastBlockData <- access pipe master db findBlock
-    latestBlock <- getBlockInfo nodeUser nodePwd "-1"
-    case latestBlock of
-      Nothing -> fail "No block data from node"
-      Just lB -> do
-        case cast' . Doc =<< lastBlockData of
-          Nothing -> do
-            print "Getting blocks"
-            blockList <-
-              mapM
-                (getBlockInfo nodeUser nodePwd . T.pack . show)
-                [(bl_height lB - 50) .. (bl_height lB)]
-            print "filtering blocks..."
-            let filteredBlockList = filter filterBlock blockList
-            print "extracting txs from blocks..."
-            let txIdList = concatMap extractTxs filteredBlockList
-            print "getting tx data from node..."
-            txList <- mapM (getTxData nodeUser nodePwd) txIdList
-            print "filtering txs..."
-            let filteredTxList = map fromJust $ filter filterTx txList
-            print "checking txs against keys..."
-            mapM_ (checkTx filteredTxList) ownerList
-            access pipe master (c_dbName config) $
-              upsertBlock (last $ catMaybes filteredBlockList)
-          Just lastBlock -> do
-            blockList' <-
-              mapM
-                (getBlockInfo nodeUser nodePwd . T.pack . show)
-                [(bl_height lastBlock + 1) .. (bl_height lB)]
-            print "filtering blocks..."
-            let filteredBlockList = filter filterBlock blockList'
-            print "extracting txs from blocks..."
-            let txIdList = concatMap extractTxs filteredBlockList
-            print "getting tx data from node..."
-            txList <- mapM (getTxData nodeUser nodePwd) txIdList
-            print "filtering txs..."
-            let filteredTxList = map fromJust $ filter filterTx txList
-            print "checking txs against keys..."
-            mapM_ (checkTx filteredTxList) ownerList
-            access pipe master (c_dbName config) $
-              upsertBlock (last $ catMaybes filteredBlockList)
-  where
-    filterBlock :: Maybe BlockResponse -> Bool
-    filterBlock b = maybe 0 bl_confirmations b >= 5
-    filterTx :: Maybe RawTxResponse -> Bool
-    filterTx t =
-      not (null (maybe [] rt_shieldedOutputs t)) ||
-      not (null (maybe [] rt_orchardActions t))
-    extractTxs :: Maybe BlockResponse -> [T.Text]
-    extractTxs = maybe [] bl_txs
-    getTxData ::
-         BS.ByteString -> BS.ByteString -> T.Text -> IO (Maybe RawTxResponse)
-    getTxData nodeUser nodePwd txid = do
-      txInfo <-
-        makeZcashCall
-          nodeUser
-          nodePwd
-          "getrawtransaction"
-          [Data.Aeson.String txid, Number $ SC.scientific 1 0]
-      let content = getResponseBody txInfo :: RpcResponse RawTxResponse
-      if isNothing (err content)
-        then return $ result content
-        else do
-          print $ err content
-          return Nothing
-    checkTx :: [RawTxResponse] -> Owner -> IO ()
-    checkTx txList' k = do
-      let sOutList = concatMap rt_shieldedOutputs txList'
-      if isValidSaplingViewingKey (E.encodeUtf8 $ oviewkey k)
-        then do
-          print "decoding Sapling tx"
-          let decodedSapList' = concatMap (decodeSaplingTx $ oviewkey k) txList'
-          let zList = catMaybes decodedSapList'
-          mapM_ (recordPayment pipe (c_dbName config) (oaddress k)) zList
-        else do
-          let vk = decodeUfvk $ E.encodeUtf8 $ oviewkey k
-          case vk of
-            Nothing -> print "Not a valid key"
-            Just v -> do
-              let decodedSapList =
-                    concatMap (decodeUnifiedSaplingTx (s_key v)) txList'
-              let zList' = catMaybes decodedSapList
-              mapM_ (recordPayment pipe (c_dbName config) (oaddress k)) zList'
-              let decodedOrchList = concatMap (decodeUnifiedOrchardTx v) txList'
-              let oList = catMaybes decodedOrchList
-              mapM_ (recordPayment pipe (c_dbName config) (oaddress k)) oList
-    decodeSaplingTx :: T.Text -> RawTxResponse -> [Maybe ZcashTx]
-    decodeSaplingTx k t =
-      map
-        (buildZcashTx t .
-         decodeSaplingOutput (bytes (decodeBech32 $ E.encodeUtf8 k)))
-        (rt_shieldedOutputs t)
-    decodeUnifiedSaplingTx :: BS.ByteString -> RawTxResponse -> [Maybe ZcashTx]
-    decodeUnifiedSaplingTx k t =
-      map (buildZcashTx t . decodeSaplingOutput k) (rt_shieldedOutputs t)
-    decodeUnifiedOrchardTx ::
-         UnifiedFullViewingKey -> RawTxResponse -> [Maybe ZcashTx]
-    decodeUnifiedOrchardTx k t =
-      map (buildZcashTx t . decryptOrchardAction k) (rt_orchardActions t)
-    buildZcashTx :: RawTxResponse -> Maybe DecodedNote -> Maybe ZcashTx
-    buildZcashTx t n =
-      case n of
-        Nothing -> Nothing
-        Just n ->
-          Just $
-          ZcashTx
-            (rt_id t)
-            (fromIntegral (a_value n) / 100000000)
-            (toInteger $ a_value n)
-            (rt_blockheight t)
-            (rt_blocktime t)
-            False
-            (rt_confirmations t)
-            (E.decodeUtf8Lenient $ a_memo n)
-    recordPayment :: Pipe -> T.Text -> T.Text -> ZcashTx -> IO ()
-    recordPayment p dbName z x = do
-      let zM = runParser pZGoMemo (T.unpack . ztxid $ x) (zmemo x)
-      case zM of
-        Right m -> do
-          case m_orderId m of
-            Nothing -> print "Not an order Tx"
-            Just orderId -> do
-              print orderId
-              o <- access p master dbName $ findOrderById (T.unpack orderId)
-              let xOrder = o >>= (cast' . Doc)
-              case xOrder of
-                Nothing -> error "Failed to retrieve order from database"
-                Just xO -> do
-                  when
-                    (not (qpaid xO) &&
-                     qtotalZec xO == zamount x && z == qaddress xO) $ do
-                    let sReg = mkRegex "(.*)-([a-fA-f0-9]{24})"
-                    let sResult = matchAllText sReg (T.unpack $ qsession xO)
-                    if not (null sResult)
-                      then case fst $ head sResult ! 1 of
-                             "Xero" -> do
-                               xeroConfig <- access p master dbName findXero
-                               let xC = xeroConfig >>= (cast' . Doc)
-                               case xC of
-                                 Nothing -> error "Failed to read Xero config"
-                                 Just xConf -> do
-                                   requestXeroToken
-                                     p
-                                     dbName
-                                     xConf
-                                     ""
-                                     (qaddress xO)
-                                   payXeroInvoice
-                                     p
-                                     dbName
-                                     (qexternalInvoice xO)
-                                     (qaddress xO)
-                                     (qtotal xO)
-                                     (qtotalZec xO)
-                                   liftIO $
-                                     access p master dbName $
-                                     markOrderPaid (T.unpack orderId, zamount x)
-                             "WC" -> do
-                               let wOwner = fst $ head sResult ! 2
-                               wooT <-
-                                 access p master dbName $
-                                 findWooToken $ Just (read wOwner)
-                               let wT = wooT >>= (cast' . Doc)
-                               case wT of
-                                 Nothing ->
-                                   error "Failed to read WooCommerce token"
-                                 Just wt -> do
-                                   let iReg = mkRegex "(.*)-(.*)-.*"
-                                   let iResult =
-                                         matchAllText
-                                           iReg
-                                           (T.unpack $ qexternalInvoice xO)
-                                   if not (null iResult)
-                                     then do
-                                       let wUrl =
-                                             E.decodeUtf8With lenientDecode .
-                                             B64.decodeLenient . C.pack $
-                                             fst $ head iResult ! 1
-                                       let iNum = fst $ head iResult ! 2
-                                       payWooOrder
-                                         (T.unpack wUrl)
-                                         (C.pack iNum)
-                                         (C.pack $ maybe "" show (q_id xO))
-                                         (C.pack . T.unpack $ w_token wt)
-                                         (C.pack . show $ qprice xO)
-                                         (C.pack . show $ qtotalZec xO)
-                                       liftIO $
-                                         access p master dbName $
-                                         markOrderPaid
-                                           (T.unpack orderId, zamount x)
-                                     else error
-                                            "Couldn't parse externalInvoice for WooCommerce"
-                             _ -> putStrLn "Not an integration order"
-                      else liftIO $
-                           access p master dbName $
-                           markOrderPaid (T.unpack orderId, zamount x)
-        Left e -> print "Unable to parse order memo"
-
 debug = flip trace
-
-instance Val BlockResponse where
-  cast' (Doc d) = do
-    c <- B.lookup "confirmations" d
-    h <- B.lookup "height" d
-    t <- B.lookup "time" d
-    txs <- B.lookup "tx" d
-    Just (BlockResponse c h t txs)
-  cast' _ = Nothing
-  val (BlockResponse c h t txs) =
-    Doc
-      [ "confirmations" =: c
-      , "height" =: h
-      , "time" =: t
-      , "tx" =: txs
-      , "network" =: ("mainnet" :: String)
-      ]
-
-upsertBlock :: BlockResponse -> Action IO ()
-upsertBlock b = do
-  let block = val b
-  case block of
-    Doc d -> upsert (select ["network" =: ("mainnet" :: String)] "blocks") d
-    _ -> return ()
-
-findBlock :: Action IO (Maybe Document)
-findBlock = findOne (select ["network" =: ("mainnet" :: String)] "blocks")

src/ZGoTx.hs

@@ -9,18 +9,16 @@ import qualified Data.Bson as B
 import Data.Char
 import Data.Maybe
 import qualified Data.Text as T
-import qualified Data.Text.Encoding as E
 import qualified Data.UUID as U
 import Data.Void
 import Database.MongoDB
 import GHC.Generics
 import Text.Megaparsec hiding (State)
 import Text.Megaparsec.Char
-import ZcashHaskell.Orchard
-import ZcashHaskell.Sapling (isValidShieldedAddress)
 
 -- | Type to model a ZGo transaction
-data ZGoTx = ZGoTx
+data ZGoTx =
+  ZGoTx
     { _id :: Maybe ObjectId
     , address :: T.Text
     , session :: T.Text
@@ -29,7 +27,8 @@ data ZGoTx = ZGoTx
     , amount :: Double
     , txid :: T.Text
     , memo :: T.Text
-  } deriving (Eq, Show, Generic)
+    }
+  deriving (Eq, Show, Generic)
 
 parseZGoTxBson :: B.Document -> Maybe ZGoTx
 parseZGoTxBson d = do
@@ -101,19 +100,19 @@ instance Val ZGoTx where
           ]
 
 -- | Type to represent and parse ZGo memos
-data ZGoMemo = ZGoMemo
+data ZGoMemo =
+  ZGoMemo
     { m_session :: Maybe U.UUID
     , m_address :: Maybe T.Text
     , m_payment :: Bool
-  , m_orderId :: Maybe T.Text
+    }
-  } deriving (Eq, Show)
+  deriving (Eq, Show)
 
 data MemoToken
   = Login !U.UUID
   | PayMsg !U.UUID
   | Address !T.Text
   | Msg !T.Text
-  | OrderId !T.Text
   deriving (Show, Eq)
 
 type Parser = Parsec Void T.Text
@@ -136,23 +135,9 @@ pSaplingAddress :: Parser MemoToken
 pSaplingAddress = do
   string "zs"
   a <- some alphaNumChar
-  if isValidShieldedAddress (E.encodeUtf8 $ "zs" <> T.pack a)
+  if length a /= 76
-    then pure $ Address $ T.pack ("zs" <> a)
+    then fail "Failed to parse Sapling address"
-    else fail "Failed to parse Sapling address"
+    else pure $ Address $ T.pack ("zs" <> a)
-
-pUnifiedAddress :: Parser MemoToken
-pUnifiedAddress = do
-  string "u1"
-  a <- some alphaNumChar
-  if isValidUnifiedAddress (E.encodeUtf8 $ "u1" <> T.pack a)
-    then pure $ Address $ T.pack ("u1" <> a)
-    else fail "Failed to parse Unified Address"
-
-pOrderId :: Parser MemoToken
-pOrderId = do
-  string "ZGo Order::"
-  a <- some hexDigitChar
-  pure $ OrderId . T.pack $ a
 
 pMsg :: Parser MemoToken
 pMsg = do
@@ -165,7 +150,7 @@ pMsg = do
 pMemo :: Parser MemoToken
 pMemo = do
   optional $ some spaceChar
-  t <- pSession <|> pSaplingAddress <|> pUnifiedAddress <|> pOrderId <|> pMsg
+  t <- pSession <|> pSaplingAddress <|> pMsg
   optional $ some spaceChar
   return t
 
@@ -190,15 +175,8 @@ isMemoToken kind t =
 pZGoMemo :: Parser ZGoMemo
 pZGoMemo = do
   tks <- some pMemo
-  pure $ ZGoMemo (isSession tks) (isAddress tks) (isPayment tks) (isOrder tks)
+  pure $ ZGoMemo (isSession tks) (isAddress tks) (isPayment 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: 1d558fc646a7758d60a721124812070de222c2e1
+    commit: fef3d3af35a09db718cddb8fc9166b2d2691a744
   - 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: 1d558fc646a7758d60a721124812070de222c2e1
+    commit: fef3d3af35a09db718cddb8fc9166b2d2691a744
     git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git
     name: zcash-haskell
     pantry-tree:
-      sha256: eab3c6817bb3cb5738725824d16eb023cb2967ef3bbaa8f8252524602f606dbb
+      sha256: ec7782cf2646da17548d59af0ea98dcbaac1b6c2176258c696a7f508db6dbc21
-      size: 1229
+      size: 1126
-    version: 0.2.0
+    version: 0.1.0
   original:
-    commit: 1d558fc646a7758d60a721124812070de222c2e1
+    commit: fef3d3af35a09db718cddb8fc9166b2d2691a744
     git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git
 - completed:
     commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05

test/Spec.hs

@@ -59,7 +59,7 @@ main = do
       describe "Memo parsers" $
         --prop "memo parsing" testMemoParser
        do
-        it "parse ZecWallet memo - Sapling" $ do
+        it "parse ZecWallet memo" $ do
           let m =
                 runParser
                   pZGoMemo
@@ -70,7 +70,7 @@ main = do
             Right m' ->
               m_session m' `shouldBe`
               U.fromString "5d3d4494-51c0-432d-8495-050419957aea"
-        it "parse YWallet memo - Sapling" $ do
+        it "parse YWallet memo" $ do
           let m =
                 runParser
                   pZGoMemo
@@ -81,7 +81,7 @@ main = do
             Right m' ->
               m_session m' `shouldBe`
               U.fromString "ad8477d3-4fdd-4c97-90b2-76630b5f77e1"
-        it "parse Zingo memo - Sapling" $ do
+        it "parse Zingo memo" $ do
           let m =
                 runParser
                   pZGoMemo
@@ -92,42 +92,6 @@ main = do
             Right m' ->
               m_session m' `shouldBe`
               U.fromString "5d3d4494-51c0-432d-8495-050419957aea"
-        it "parse ZecWallet memo - Orchard" $ do
-          let m =
-                runParser
-                  pZGoMemo
-                  "Zecwalllet memo"
-                  "ZGO::5d3d4494-51c0-432d-8495-050419957aea\nReply-To:\nu17n7hpwaujyq7ux8f9jpyymtnk5urw7pyrf60smp5mawy7jgz325hfvz3jn3zsfya8yxryf9q7ldk8nu8df0emra5wne28zq9d9nm2pu4x6qwjha565av9aze0xgujgslz74ufkj0c0cylqwjyrh9msjfh7jzal6d3qzrnhkkqy3pqm8j63y07jxj7txqeac982778rmt64f32aum94x"
-          case m of
-            Left e -> putStrLn $ errorBundlePretty e
-            Right m' ->
-              m_address m' `shouldBe`
-              Just
-                "u17n7hpwaujyq7ux8f9jpyymtnk5urw7pyrf60smp5mawy7jgz325hfvz3jn3zsfya8yxryf9q7ldk8nu8df0emra5wne28zq9d9nm2pu4x6qwjha565av9aze0xgujgslz74ufkj0c0cylqwjyrh9msjfh7jzal6d3qzrnhkkqy3pqm8j63y07jxj7txqeac982778rmt64f32aum94x"
-        it "parse YWallet memo - Orchard" $ do
-          let m =
-                runParser
-                  pZGoMemo
-                  "Ywallet memo"
-                  "\128737MSG\nu17n7hpwaujyq7ux8f9jpyymtnk5urw7pyrf60smp5mawy7jgz325hfvz3jn3zsfya8yxryf9q7ldk8nu8df0emra5wne28zq9d9nm2pu4x6qwjha565av9aze0xgujgslz74ufkj0c0cylqwjyrh9msjfh7jzal6d3qzrnhkkqy3pqm8j63y07jxj7txqeac982778rmt64f32aum94x\n\nZGO::ad8477d3-4fdd-4c97-90b2-76630b5f77e1"
-          case m of
-            Left e -> putStrLn $ errorBundlePretty e
-            Right m' ->
-              m_address m' `shouldBe`
-              Just
-                "u17n7hpwaujyq7ux8f9jpyymtnk5urw7pyrf60smp5mawy7jgz325hfvz3jn3zsfya8yxryf9q7ldk8nu8df0emra5wne28zq9d9nm2pu4x6qwjha565av9aze0xgujgslz74ufkj0c0cylqwjyrh9msjfh7jzal6d3qzrnhkkqy3pqm8j63y07jxj7txqeac982778rmt64f32aum94x"
-        it "parse Zingo memo - Orchard" $ do
-          let m =
-                runParser
-                  pZGoMemo
-                  "Zingo memo"
-                  "ZGO::5d3d4494-51c0-432d-8495-050419957aea\nReply to:\nu17n7hpwaujyq7ux8f9jpyymtnk5urw7pyrf60smp5mawy7jgz325hfvz3jn3zsfya8yxryf9q7ldk8nu8df0emra5wne28zq9d9nm2pu4x6qwjha565av9aze0xgujgslz74ufkj0c0cylqwjyrh9msjfh7jzal6d3qzrnhkkqy3pqm8j63y07jxj7txqeac982778rmt64f32aum94x"
-          case m of
-            Left e -> putStrLn $ errorBundlePretty e
-            Right m' ->
-              m_address m' `shouldBe`
-              Just
-                "u17n7hpwaujyq7ux8f9jpyymtnk5urw7pyrf60smp5mawy7jgz325hfvz3jn3zsfya8yxryf9q7ldk8nu8df0emra5wne28zq9d9nm2pu4x6qwjha565av9aze0xgujgslz74ufkj0c0cylqwjyrh9msjfh7jzal6d3qzrnhkkqy3pqm8j63y07jxj7txqeac982778rmt64f32aum94x"
       describe "PIN generator" $ do
         it "should give a 7 digit" $ do
           pin <- generatePin
@@ -298,7 +262,7 @@ main = do
           it "return owner by id" $ do
             req <-
               testGet
-                "/ownerid"
+                "/api/ownerid"
                 [ ("id", Just "627ad3492b05a76be3000001")
                 , ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
                 ]
@@ -691,8 +655,6 @@ main = do
                 "zxviews1qdjagrrpqqqqpq8es75mlu6rref0qyrstchf8dxzeygtsejwfqu8ckhwl2qj5m8am7lmupxk3vkvdjm8pawjpmesjfapvsqw96pa46c2z0kk7letrxf7mkltwz54fwpxc7kc79mm5kce3rwn5ssl009zwsra2spppwgrx25s9k5hq65f69l4jz2tjmqgy0pl49qmtaj3nudk6wglwe2hpa327hydlchtyq9av6wjd6hu68e04ahwk9a9n2kt0kj3nj99nue65awtu5cwwcpjs"
           let vk2 =
                 "zxviews1qdjagrrpqqqqpq8es75mlufakef0qyrstchf8dxzeygtsejwfqu8ckhwl2qj5m8am7lmupxk3vkvdjm8pawjpmesjfapvsqw96pa46c2z0kk7letrxf7mkltwz54fwpxc7kc79mm5kce3rwn5ssl009zwsra2spppwgrx25s9k5hq65f69l4jz2tjmqgy0pl49qmtaj3nudk6wglwe2hpa327hydlchtyq9av6wjd6hu68e04ahwk9a9n2kt0kj3nj99nue65awtu5cwwcpjs"
-          let vk3 =
-                "uview1u833rp8yykd7h4druwht6xp6k8krle45fx8hqsw6vzw63n24atxpcatws82z092kryazuu6d7rayyut8m36wm4wpjy2z8r9hj48fx5pf49gw4sjrq8503qpz3vqj5hg0vg9vsqeasg5qjuyh94uyfm7v76udqcm2m0wfc25hcyqswcn56xxduq3xkgxkr0l73cjy88fdvf90eq5fda9g6x7yv7d0uckpevxg6540wc76xrc4axxvlt03ptaa2a0rektglmdy68656f3uzcdgqqyu0t7wk5cvwghyyvgqc0rp3vgu5ye4nd236ml57rjh083a2755qemf6dk6pw0qrnfm7246s8eg2hhzkzpf9h73chhng7xhmyem2sjh8rs2m9nhfcslsgenm"
           it "returns 401 with bad session" $ do
             req <-
               testPostJson "/api/ownervk" $
@@ -733,7 +695,7 @@ main = do
                 [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
                 req
             getResponseStatus res `shouldBe` badRequest400
-          it "succeeds with correct Sapling key" $ do
+          it "succeeds with correct key" $ do
             req <-
               testPostJson "/api/ownervk" $
               A.object ["payload" A..= (vk1 :: String)]
@@ -743,26 +705,6 @@ 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
@@ -1201,25 +1143,8 @@ 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 $
+        map unwrapDoc $ filter filterDocs $ val <$> [myUser, myUser1, myUser2]
-        filter filterDocs $ val <$> [myUser, myUser1, myUser2, myUser3, myUser4]
   _ <- access pipe master "test" (insertAll_ "users" userList)
   let myOwner =
         Owner
@@ -1275,60 +1200,6 @@ 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
@@ -1338,14 +1209,6 @@ 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 =