Compare commits
No commits in common. "a134947df6af5b0729be20540addffdc91fd36c6" and "c58aa2f8c016007dbf5d1e2e83e9687c84f47354" have entirely different histories.
a134947df6
...
c58aa2f8c0
7 changed files with 166 additions and 302 deletions
15
CHANGELOG.md
15
CHANGELOG.md
|
@ -6,22 +6,9 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
|
||||||
|
|
||||||
## [Unreleased]
|
## [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
|
|
||||||
|
|
||||||
- MongoDB driver updated to support MongoDB 6.
|
- 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]
|
## [1.7.0]
|
||||||
|
|
||||||
|
|
139
src/Owner.hs
139
src/Owner.hs
|
@ -14,33 +14,35 @@ import Database.MongoDB
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
|
|
||||||
-- | Type to represent a ZGo shop owner/business
|
-- | Type to represent a ZGo shop owner/business
|
||||||
data Owner = Owner
|
data Owner =
|
||||||
{ o_id :: Maybe ObjectId
|
Owner
|
||||||
, oaddress :: T.Text
|
{ o_id :: Maybe ObjectId
|
||||||
, oname :: T.Text
|
, oaddress :: T.Text
|
||||||
, ocurrency :: T.Text
|
, oname :: T.Text
|
||||||
, otax :: Bool
|
, ocurrency :: T.Text
|
||||||
, otaxValue :: Double
|
, otax :: Bool
|
||||||
, ovat :: Bool
|
, otaxValue :: Double
|
||||||
, ovatValue :: Double
|
, ovat :: Bool
|
||||||
, ofirst :: T.Text
|
, ovatValue :: Double
|
||||||
, olast :: T.Text
|
, ofirst :: T.Text
|
||||||
, oemail :: T.Text
|
, olast :: T.Text
|
||||||
, ostreet :: T.Text
|
, oemail :: T.Text
|
||||||
, ocity :: T.Text
|
, ostreet :: T.Text
|
||||||
, ostate :: T.Text
|
, ocity :: T.Text
|
||||||
, opostal :: T.Text
|
, ostate :: T.Text
|
||||||
, ophone :: T.Text
|
, opostal :: T.Text
|
||||||
, owebsite :: T.Text
|
, ophone :: T.Text
|
||||||
, ocountry :: T.Text
|
, owebsite :: T.Text
|
||||||
, opaid :: Bool
|
, ocountry :: T.Text
|
||||||
, ozats :: Bool
|
, opaid :: Bool
|
||||||
, oinvoices :: Bool
|
, ozats :: Bool
|
||||||
, oexpiration :: UTCTime
|
, oinvoices :: Bool
|
||||||
, opayconf :: Bool
|
, oexpiration :: UTCTime
|
||||||
, oviewkey :: T.Text
|
, opayconf :: Bool
|
||||||
, ocrmToken :: T.Text
|
, oviewkey :: T.Text
|
||||||
} deriving (Eq, Show, Generic, Typeable)
|
, ocrmToken :: T.Text
|
||||||
|
}
|
||||||
|
deriving (Eq, Show, Generic, Typeable)
|
||||||
|
|
||||||
instance ToJSON Owner where
|
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) =
|
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,19 +276,21 @@ instance Val Owner where
|
||||||
]
|
]
|
||||||
|
|
||||||
-- | Type to represent informational data for Owners from UI
|
-- | Type to represent informational data for Owners from UI
|
||||||
data OwnerData = OwnerData
|
data OwnerData =
|
||||||
{ od_first :: T.Text
|
OwnerData
|
||||||
, od_last :: T.Text
|
{ od_first :: T.Text
|
||||||
, od_name :: T.Text
|
, od_last :: T.Text
|
||||||
, od_street :: T.Text
|
, od_name :: T.Text
|
||||||
, od_city :: T.Text
|
, od_street :: T.Text
|
||||||
, od_state :: T.Text
|
, od_city :: T.Text
|
||||||
, od_postal :: T.Text
|
, od_state :: T.Text
|
||||||
, od_country :: T.Text
|
, od_postal :: T.Text
|
||||||
, od_email :: T.Text
|
, od_country :: T.Text
|
||||||
, od_website :: T.Text
|
, od_email :: T.Text
|
||||||
, od_phone :: T.Text
|
, od_website :: T.Text
|
||||||
} deriving (Eq, Show, Generic)
|
, od_phone :: T.Text
|
||||||
|
}
|
||||||
|
deriving (Eq, Show, Generic)
|
||||||
|
|
||||||
instance FromJSON OwnerData where
|
instance FromJSON OwnerData where
|
||||||
parseJSON =
|
parseJSON =
|
||||||
|
@ -304,23 +308,25 @@ instance FromJSON OwnerData where
|
||||||
ph <- obj .: "phone"
|
ph <- obj .: "phone"
|
||||||
pure $ OwnerData f l n s c st p co e w ph
|
pure $ OwnerData f l n s c st p co e w ph
|
||||||
|
|
||||||
data OwnerSettings = OwnerSettings
|
data OwnerSettings =
|
||||||
{ os_id :: Maybe ObjectId
|
OwnerSettings
|
||||||
, os_address :: T.Text
|
{ os_id :: Maybe ObjectId
|
||||||
, os_name :: T.Text
|
, os_address :: T.Text
|
||||||
, os_currency :: T.Text
|
, os_name :: T.Text
|
||||||
, os_tax :: Bool
|
, os_currency :: T.Text
|
||||||
, os_taxValue :: Double
|
, os_tax :: Bool
|
||||||
, os_vat :: Bool
|
, os_taxValue :: Double
|
||||||
, os_vatValue :: Double
|
, os_vat :: Bool
|
||||||
, os_paid :: Bool
|
, os_vatValue :: Double
|
||||||
, os_zats :: Bool
|
, os_paid :: Bool
|
||||||
, os_invoices :: Bool
|
, os_zats :: Bool
|
||||||
, os_expiration :: UTCTime
|
, os_invoices :: Bool
|
||||||
, os_payconf :: Bool
|
, os_expiration :: UTCTime
|
||||||
, os_crmToken :: T.Text
|
, os_payconf :: Bool
|
||||||
, os_viewKey :: T.Text
|
, os_crmToken :: T.Text
|
||||||
} deriving (Eq, Show, Generic)
|
, os_viewKey :: T.Text
|
||||||
|
}
|
||||||
|
deriving (Eq, Show, Generic)
|
||||||
|
|
||||||
instance FromJSON OwnerSettings where
|
instance FromJSON OwnerSettings where
|
||||||
parseJSON =
|
parseJSON =
|
||||||
|
@ -418,11 +424,6 @@ findExpiringOwners now =
|
||||||
["paid" =: True, "expiration" =: ["$lte" =: addUTCTime 172800 now]]
|
["paid" =: True, "expiration" =: ["$lte" =: addUTCTime 172800 now]]
|
||||||
"owners")
|
"owners")
|
||||||
|
|
||||||
findWithKeys :: Action IO [Document]
|
|
||||||
findWithKeys =
|
|
||||||
rest =<<
|
|
||||||
find (select ["paid" =: True, "invoices" =: True, "payconf" =: True] "owners")
|
|
||||||
|
|
||||||
removePro :: T.Text -> Action IO ()
|
removePro :: T.Text -> Action IO ()
|
||||||
removePro o =
|
removePro o =
|
||||||
modify (select ["address" =: o] "owners") ["$set" =: ["invoices" =: False]]
|
modify (select ["address" =: o] "owners") ["$set" =: ["invoices" =: False]]
|
||||||
|
@ -449,12 +450,14 @@ upsertViewingKey o vk =
|
||||||
modify (select ["_id" =: o_id o] "owners") ["$set" =: ["viewKey" =: vk]]
|
modify (select ["_id" =: o_id o] "owners") ["$set" =: ["viewKey" =: vk]]
|
||||||
|
|
||||||
-- | Type for a pro session
|
-- | Type for a pro session
|
||||||
data ZGoProSession = ZGoProSession
|
data ZGoProSession =
|
||||||
{ ps_id :: Maybe ObjectId
|
ZGoProSession
|
||||||
, psaddress :: T.Text
|
{ ps_id :: Maybe ObjectId
|
||||||
, psexpiration :: UTCTime
|
, psaddress :: T.Text
|
||||||
, psclosed :: Bool
|
, psexpiration :: UTCTime
|
||||||
} deriving (Eq, Show)
|
, psclosed :: Bool
|
||||||
|
}
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
instance Val ZGoProSession where
|
instance Val ZGoProSession where
|
||||||
cast' (Doc d) = do
|
cast' (Doc d) = do
|
||||||
|
|
|
@ -25,7 +25,7 @@ import Data.Char
|
||||||
import qualified Data.HashMap.Strict as HM
|
import qualified Data.HashMap.Strict as HM
|
||||||
import Data.HexString
|
import Data.HexString
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import qualified Data.Scientific as SC
|
import qualified Data.Scientific as Scientific
|
||||||
import Data.SecureMem
|
import Data.SecureMem
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import qualified Data.Text.Encoding as E
|
import qualified Data.Text.Encoding as E
|
||||||
|
@ -37,8 +37,9 @@ import Data.Time.Format
|
||||||
import Data.Typeable
|
import Data.Typeable
|
||||||
import qualified Data.UUID as U
|
import qualified Data.UUID as U
|
||||||
import qualified Data.Vector as V
|
import qualified Data.Vector as V
|
||||||
|
import Data.Vector.Internal.Check (doChecks)
|
||||||
import Data.Word
|
import Data.Word
|
||||||
import Database.MongoDB hiding (Order, lookup)
|
import Database.MongoDB hiding (Order)
|
||||||
import Debug.Trace
|
import Debug.Trace
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
import Item
|
import Item
|
||||||
|
@ -65,20 +66,47 @@ import Web.Scotty
|
||||||
import WooCommerce
|
import WooCommerce
|
||||||
import Xero
|
import Xero
|
||||||
import ZGoTx
|
import ZGoTx
|
||||||
import ZcashHaskell.Orchard
|
|
||||||
import ZcashHaskell.Sapling
|
import ZcashHaskell.Sapling
|
||||||
import ZcashHaskell.Types
|
import ZcashHaskell.Types (RawData(..))
|
||||||
( BlockResponse(..)
|
import ZcashHaskell.Utils (decodeBech32)
|
||||||
, RawData(..)
|
|
||||||
, RawTxResponse(..)
|
|
||||||
, RpcCall(..)
|
|
||||||
, RpcError(..)
|
|
||||||
, RpcResponse(..)
|
|
||||||
, UnifiedFullViewingKey(..)
|
|
||||||
)
|
|
||||||
import ZcashHaskell.Utils (decodeBech32, makeZcashCall)
|
|
||||||
|
|
||||||
-- Models for API objects
|
-- 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
|
data Payload r = Payload
|
||||||
{ payload :: r
|
{ payload :: r
|
||||||
} deriving (Show, Generic, ToJSON)
|
} deriving (Show, Generic, ToJSON)
|
||||||
|
@ -1193,7 +1221,7 @@ routes pipe config = do
|
||||||
"z_importviewingkey"
|
"z_importviewingkey"
|
||||||
[ Data.Aeson.String (T.strip . T.pack $ q)
|
[ Data.Aeson.String (T.strip . T.pack $ q)
|
||||||
, "no"
|
, "no"
|
||||||
] -- TODO: Remove this call to the node
|
]
|
||||||
let content =
|
let content =
|
||||||
getResponseBody vkInfo :: RpcResponse Object
|
getResponseBody vkInfo :: RpcResponse Object
|
||||||
if isNothing (err content)
|
if isNothing (err content)
|
||||||
|
@ -1205,7 +1233,7 @@ routes pipe config = do
|
||||||
text $ L.pack . show $ err content
|
text $ L.pack . show $ err content
|
||||||
status badRequest400
|
status badRequest400
|
||||||
else status forbidden403
|
else status forbidden403
|
||||||
else status badRequest400 -- TODO: add Unified VK support
|
else status badRequest400
|
||||||
--Get items associated with the given address
|
--Get items associated with the given address
|
||||||
get "/api/items" $ do
|
get "/api/items" $ do
|
||||||
session <- param "session"
|
session <- param "session"
|
||||||
|
@ -1439,24 +1467,25 @@ routes pipe config = do
|
||||||
{-liftAndCatchIO $-}
|
{-liftAndCatchIO $-}
|
||||||
{-mapM (run . loadLangComponent) (langComp :: [LangComponent])-}
|
{-mapM (run . loadLangComponent) (langComp :: [LangComponent])-}
|
||||||
{-status created201-}
|
{-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
|
-- | 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
|
-- |Timer for repeating actions
|
||||||
setInterval :: Int -> IO () -> IO ()
|
setInterval :: Int -> IO () -> IO ()
|
||||||
setInterval secs func = do
|
setInterval secs func = do
|
||||||
|
@ -1498,7 +1527,7 @@ listTxs user pwd a confs = do
|
||||||
user
|
user
|
||||||
pwd
|
pwd
|
||||||
"z_listreceivedbyaddress"
|
"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])))
|
(Either HttpException (Response (RpcResponse [ZcashTx])))
|
||||||
case res of
|
case res of
|
||||||
Right txList -> do
|
Right txList -> do
|
||||||
|
@ -1696,7 +1725,7 @@ payOwner p d x =
|
||||||
markOwnerPaid :: Pipe -> T.Text -> Payment -> IO ()
|
markOwnerPaid :: Pipe -> T.Text -> Payment -> IO ()
|
||||||
markOwnerPaid pipe db pmt = do
|
markOwnerPaid pipe db pmt = do
|
||||||
user <- access pipe master db (findUser $ psession pmt)
|
user <- access pipe master db (findUser $ psession pmt)
|
||||||
-- print pmt
|
print pmt
|
||||||
let parsedUser = parseUserBson =<< user
|
let parsedUser = parseUserBson =<< user
|
||||||
let zaddy = maybe "" uaddress parsedUser
|
let zaddy = maybe "" uaddress parsedUser
|
||||||
owner <- access pipe master db $ findOwner zaddy
|
owner <- access pipe master db $ findOwner zaddy
|
||||||
|
@ -1802,119 +1831,4 @@ generateToken = do
|
||||||
rngState <- newCryptoRNGState
|
rngState <- newCryptoRNGState
|
||||||
runCryptoRNGT rngState $ randomString 24 "abcdef0123456789"
|
runCryptoRNGT rngState $ randomString 24 "abcdef0123456789"
|
||||||
|
|
||||||
getBlockInfo ::
|
|
||||||
BS.ByteString -> BS.ByteString -> SC.Scientific -> IO (Maybe BlockResponse)
|
|
||||||
getBlockInfo nodeUser nodePwd bh = do
|
|
||||||
blockInfo <- makeZcashCall nodeUser nodePwd "getblock" [Number bh]
|
|
||||||
let content = getResponseBody blockInfo :: RpcResponse BlockResponse
|
|
||||||
if isNothing (err content)
|
|
||||||
then return $ result content
|
|
||||||
else do
|
|
||||||
print $ err content
|
|
||||||
return Nothing
|
|
||||||
|
|
||||||
scanTxNative :: Pipe -> T.Text -> BS.ByteString -> BS.ByteString -> IO ()
|
|
||||||
scanTxNative pipe db nodeUser nodePwd = do
|
|
||||||
keyOwnerList <- access pipe master db findWithKeys
|
|
||||||
unless (null keyOwnerList) $ do
|
|
||||||
let ownerList = cast' . Doc <$> keyOwnerList
|
|
||||||
let keyList = map (maybe "" oviewkey) ownerList
|
|
||||||
lastBlockData <- access pipe master db findBlock
|
|
||||||
latestBlock <- getBlockInfo nodeUser nodePwd (SC.scientific (-1) 0)
|
|
||||||
case latestBlock of
|
|
||||||
Nothing -> fail "No block data from node"
|
|
||||||
Just lB -> do
|
|
||||||
case cast' . Doc =<< lastBlockData of
|
|
||||||
Nothing -> do
|
|
||||||
blockList <-
|
|
||||||
mapM
|
|
||||||
(getBlockInfo nodeUser nodePwd . fromInteger)
|
|
||||||
[2220000 .. (bl_height lB)]
|
|
||||||
let filteredBlockList = filter filterBlock blockList
|
|
||||||
let txIdList = concatMap extractTxs filteredBlockList
|
|
||||||
txList <- mapM (getTxData nodeUser nodePwd) txIdList
|
|
||||||
let filteredTxList = map fromJust $ filter filterTx txList
|
|
||||||
mapM_ (checkTx filteredTxList) keyList
|
|
||||||
Just lastBlock -> do
|
|
||||||
let blockList' = [(bl_height lastBlock + 1) .. (bl_height lB)]
|
|
||||||
print blockList'
|
|
||||||
print keyList
|
|
||||||
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]
|
|
||||||
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 txList k = do
|
|
||||||
if isValidSaplingViewingKey (E.encodeUtf8 k)
|
|
||||||
then do
|
|
||||||
let decodedTxList =
|
|
||||||
map
|
|
||||||
(decodeSaplingOutput (E.encodeUtf8 k))
|
|
||||||
(concatMap
|
|
||||||
rt_shieldedOutputs
|
|
||||||
(filter (\x -> rt_shieldedOutputs x /= []) txList))
|
|
||||||
print decodedTxList
|
|
||||||
else do
|
|
||||||
let vk = decodeUfvk $ E.encodeUtf8 k
|
|
||||||
case vk of
|
|
||||||
Nothing -> print "Not a valid key"
|
|
||||||
Just v -> do
|
|
||||||
let decodedSapList =
|
|
||||||
map
|
|
||||||
(decodeSaplingOutput (s_key v))
|
|
||||||
(concatMap rt_shieldedOutputs txList)
|
|
||||||
print decodedSapList
|
|
||||||
let decodedOrchList =
|
|
||||||
map
|
|
||||||
(decryptOrchardAction v)
|
|
||||||
(concatMap rt_orchardActions txList)
|
|
||||||
print decodedOrchList
|
|
||||||
|
|
||||||
debug = flip trace
|
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")
|
|
||||||
|
|
51
src/ZGoTx.hs
51
src/ZGoTx.hs
|
@ -9,27 +9,26 @@ import qualified Data.Bson as B
|
||||||
import Data.Char
|
import Data.Char
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import qualified Data.Text.Encoding as E
|
|
||||||
import qualified Data.UUID as U
|
import qualified Data.UUID as U
|
||||||
import Data.Void
|
import Data.Void
|
||||||
import Database.MongoDB
|
import Database.MongoDB
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
import Text.Megaparsec hiding (State)
|
import Text.Megaparsec hiding (State)
|
||||||
import Text.Megaparsec.Char
|
import Text.Megaparsec.Char
|
||||||
import ZcashHaskell.Orchard
|
|
||||||
import ZcashHaskell.Sapling (isValidShieldedAddress)
|
|
||||||
|
|
||||||
-- | Type to model a ZGo transaction
|
-- | Type to model a ZGo transaction
|
||||||
data ZGoTx = ZGoTx
|
data ZGoTx =
|
||||||
{ _id :: Maybe ObjectId
|
ZGoTx
|
||||||
, address :: T.Text
|
{ _id :: Maybe ObjectId
|
||||||
, session :: T.Text
|
, address :: T.Text
|
||||||
, confirmations :: Integer
|
, session :: T.Text
|
||||||
, blocktime :: Integer
|
, confirmations :: Integer
|
||||||
, amount :: Double
|
, blocktime :: Integer
|
||||||
, txid :: T.Text
|
, amount :: Double
|
||||||
, memo :: T.Text
|
, txid :: T.Text
|
||||||
} deriving (Eq, Show, Generic)
|
, memo :: T.Text
|
||||||
|
}
|
||||||
|
deriving (Eq, Show, Generic)
|
||||||
|
|
||||||
parseZGoTxBson :: B.Document -> Maybe ZGoTx
|
parseZGoTxBson :: B.Document -> Maybe ZGoTx
|
||||||
parseZGoTxBson d = do
|
parseZGoTxBson d = do
|
||||||
|
@ -101,11 +100,13 @@ instance Val ZGoTx where
|
||||||
]
|
]
|
||||||
|
|
||||||
-- | Type to represent and parse ZGo memos
|
-- | Type to represent and parse ZGo memos
|
||||||
data ZGoMemo = ZGoMemo
|
data ZGoMemo =
|
||||||
{ m_session :: Maybe U.UUID
|
ZGoMemo
|
||||||
, m_address :: Maybe T.Text
|
{ m_session :: Maybe U.UUID
|
||||||
, m_payment :: Bool
|
, m_address :: Maybe T.Text
|
||||||
} deriving (Eq, Show)
|
, m_payment :: Bool
|
||||||
|
}
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
data MemoToken
|
data MemoToken
|
||||||
= Login !U.UUID
|
= Login !U.UUID
|
||||||
|
@ -134,17 +135,9 @@ pSaplingAddress :: Parser MemoToken
|
||||||
pSaplingAddress = do
|
pSaplingAddress = do
|
||||||
string "zs"
|
string "zs"
|
||||||
a <- some alphaNumChar
|
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"
|
|
||||||
|
|
||||||
pMsg :: Parser MemoToken
|
pMsg :: Parser MemoToken
|
||||||
pMsg = do
|
pMsg = do
|
||||||
|
|
|
@ -45,7 +45,7 @@ extra-deps:
|
||||||
- git: https://github.com/reach-sh/haskell-hexstring.git
|
- git: https://github.com/reach-sh/haskell-hexstring.git
|
||||||
commit: 085c16fb21b9f856a435a3faab980e7e0b319341
|
commit: 085c16fb21b9f856a435a3faab980e7e0b319341
|
||||||
- git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git
|
- git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git
|
||||||
commit: d78c269d96fe7d8a626cf701b8051c40f251e232
|
commit: fef3d3af35a09db718cddb8fc9166b2d2691a744
|
||||||
- git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git
|
- git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git
|
||||||
commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05
|
commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05
|
||||||
- git: https://github.com/well-typed/borsh.git
|
- git: https://github.com/well-typed/borsh.git
|
||||||
|
|
|
@ -16,15 +16,15 @@ packages:
|
||||||
commit: 085c16fb21b9f856a435a3faab980e7e0b319341
|
commit: 085c16fb21b9f856a435a3faab980e7e0b319341
|
||||||
git: https://github.com/reach-sh/haskell-hexstring.git
|
git: https://github.com/reach-sh/haskell-hexstring.git
|
||||||
- completed:
|
- completed:
|
||||||
commit: d78c269d96fe7d8a626cf701b8051c40f251e232
|
commit: fef3d3af35a09db718cddb8fc9166b2d2691a744
|
||||||
git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git
|
git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git
|
||||||
name: zcash-haskell
|
name: zcash-haskell
|
||||||
pantry-tree:
|
pantry-tree:
|
||||||
sha256: 69201a27ac966be478ef0b8e3fa8e8bf5cbcc67a58cd254326545eb4f3e93569
|
sha256: ec7782cf2646da17548d59af0ea98dcbaac1b6c2176258c696a7f508db6dbc21
|
||||||
size: 1229
|
size: 1126
|
||||||
version: 0.2.0
|
version: 0.1.0
|
||||||
original:
|
original:
|
||||||
commit: d78c269d96fe7d8a626cf701b8051c40f251e232
|
commit: fef3d3af35a09db718cddb8fc9166b2d2691a744
|
||||||
git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git
|
git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git
|
||||||
- completed:
|
- completed:
|
||||||
commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05
|
commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05
|
||||||
|
|
41
test/Spec.hs
41
test/Spec.hs
|
@ -59,7 +59,7 @@ main = do
|
||||||
describe "Memo parsers" $
|
describe "Memo parsers" $
|
||||||
--prop "memo parsing" testMemoParser
|
--prop "memo parsing" testMemoParser
|
||||||
do
|
do
|
||||||
it "parse ZecWallet memo - Sapling" $ do
|
it "parse ZecWallet memo" $ do
|
||||||
let m =
|
let m =
|
||||||
runParser
|
runParser
|
||||||
pZGoMemo
|
pZGoMemo
|
||||||
|
@ -70,7 +70,7 @@ main = do
|
||||||
Right m' ->
|
Right m' ->
|
||||||
m_session m' `shouldBe`
|
m_session m' `shouldBe`
|
||||||
U.fromString "5d3d4494-51c0-432d-8495-050419957aea"
|
U.fromString "5d3d4494-51c0-432d-8495-050419957aea"
|
||||||
it "parse YWallet memo - Sapling" $ do
|
it "parse YWallet memo" $ do
|
||||||
let m =
|
let m =
|
||||||
runParser
|
runParser
|
||||||
pZGoMemo
|
pZGoMemo
|
||||||
|
@ -81,7 +81,7 @@ main = do
|
||||||
Right m' ->
|
Right m' ->
|
||||||
m_session m' `shouldBe`
|
m_session m' `shouldBe`
|
||||||
U.fromString "ad8477d3-4fdd-4c97-90b2-76630b5f77e1"
|
U.fromString "ad8477d3-4fdd-4c97-90b2-76630b5f77e1"
|
||||||
it "parse Zingo memo - Sapling" $ do
|
it "parse Zingo memo" $ do
|
||||||
let m =
|
let m =
|
||||||
runParser
|
runParser
|
||||||
pZGoMemo
|
pZGoMemo
|
||||||
|
@ -92,39 +92,6 @@ main = do
|
||||||
Right m' ->
|
Right m' ->
|
||||||
m_session m' `shouldBe`
|
m_session m' `shouldBe`
|
||||||
U.fromString "5d3d4494-51c0-432d-8495-050419957aea"
|
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_session m' `shouldBe`
|
|
||||||
U.fromString "5d3d4494-51c0-432d-8495-050419957aea"
|
|
||||||
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_session m' `shouldBe`
|
|
||||||
U.fromString "ad8477d3-4fdd-4c97-90b2-76630b5f77e1"
|
|
||||||
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_session m' `shouldBe`
|
|
||||||
U.fromString "5d3d4494-51c0-432d-8495-050419957aea"
|
|
||||||
describe "PIN generator" $ do
|
describe "PIN generator" $ do
|
||||||
it "should give a 7 digit" $ do
|
it "should give a 7 digit" $ do
|
||||||
pin <- generatePin
|
pin <- generatePin
|
||||||
|
@ -295,7 +262,7 @@ main = do
|
||||||
it "return owner by id" $ do
|
it "return owner by id" $ do
|
||||||
req <-
|
req <-
|
||||||
testGet
|
testGet
|
||||||
"/ownerid"
|
"/api/ownerid"
|
||||||
[ ("id", Just "627ad3492b05a76be3000001")
|
[ ("id", Just "627ad3492b05a76be3000001")
|
||||||
, ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
|
, ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
|
||||||
]
|
]
|
||||||
|
|
Loading…
Reference in a new issue