zgo-backend/src/ZGoBackend.hs

1083 lines
33 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
module ZGoBackend where
import Config
import Control.Concurrent (forkIO, threadDelay)
import Control.Monad
import Control.Monad.IO.Class
import Data.Aeson
import Data.Array
import qualified Data.Bson as B
import qualified Data.ByteString as BS
import Data.Char
import qualified Data.HashMap.Strict as HM
import Data.HexString
import Data.Maybe
import qualified Data.Scientific as Scientific
import Data.SecureMem
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.Text.Lazy as L
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Typeable
import qualified Data.Vector as V
import Data.Vector.Internal.Check (doChecks)
import Data.Word
import Database.MongoDB
import Debug.Trace
import GHC.Generics
import Item
import Network.HTTP.Simple
import Network.HTTP.Types (created201)
import Network.HTTP.Types.Status
import Network.Wai.Middleware.Cors
import Network.Wai.Middleware.HttpAuth
import Numeric
import Order
import Owner
import Payment
import System.IO.Unsafe
import System.Random
import Test.QuickCheck
import Test.QuickCheck.Instances
import Test.QuickCheck.Property (Result(ok))
import Text.Regex
import Text.Regex.Base
import User
import Web.Scotty
import Xero
import ZGoTx
-- 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)
instance (FromJSON r) => FromJSON (Payload r) where
parseJSON (Object obj) = Payload <$> obj .: "payload"
parseJSON _ = mzero
-- | Type to model a (simplified) block of Zcash blockchain
data Block =
Block
{ height :: Integer
, size :: Integer
}
deriving (Show, Generic, ToJSON)
instance FromJSON Block where
parseJSON (Object obj) = Block <$> obj .: "height" <*> obj .: "size"
parseJSON _ = mzero
-- | Type to model a Zcash shielded transaction
data ZcashTx =
ZcashTx
{ ztxid :: T.Text
, zamount :: Double
, zamountZat :: Integer
, zblockheight :: Integer
, zblocktime :: Integer
, zchange :: Bool
, zconfirmations :: Integer
, zmemo :: T.Text
}
deriving (Show, Generic)
instance FromJSON ZcashTx where
parseJSON =
withObject "ZcashTx" $ \obj -> do
t <- obj .: "txid"
a <- obj .: "amount"
aZ <- obj .: "amountZat"
bh <- obj .: "blockheight"
bt <- obj .: "blocktime"
c <- obj .:? "change"
conf <- obj .: "confirmations"
m <- obj .: "memo"
pure $
ZcashTx
t
a
aZ
bh
bt
(fromMaybe False c)
conf
(T.filter (/= '\NUL') $ decodeHexText m)
instance ToJSON ZcashTx where
toJSON (ZcashTx t a aZ bh bt c conf m) =
object
[ "amount" .= a
, "amountZat" .= aZ
, "txid" .= t
, "blockheight" .= bh
, "blocktime" .= bt
, "change" .= c
, "confirmations" .= conf
, "memo" .= m
]
instance Arbitrary ZcashTx where
arbitrary = do
a <- arbitrary
aZ <- arbitrary
t <- arbitrary
bh <- arbitrary
bt <- arbitrary
c <- arbitrary
cm <- arbitrary
ZcashTx a aZ t bh bt c cm <$> arbitrary
-- | A type to model an address group
data AddressGroup =
AddressGroup
{ agsource :: AddressSource
, agtransparent :: [ZcashAddress]
, agsapling :: [ZcashAddress]
, agunified :: [ZcashAddress]
}
deriving (Show, Generic)
instance FromJSON AddressGroup where
parseJSON =
withObject "AddressGroup" $ \obj -> do
s <- obj .: "source"
t <- obj .:? "transparent"
sap <- obj .:? "sapling"
uni <- obj .:? "unified"
sL <- processSapling sap s
tL <- processTransparent t s
uL <- processUnified uni
return $ AddressGroup s tL (concat sL) (concat uL)
where
processTransparent c s1 =
case c of
Nothing -> return []
Just x -> do
x' <- x .: "addresses"
return $ map (ZcashAddress s1 [Transparent] Nothing) x'
processSapling k s2 =
case k of
Nothing -> return []
Just y -> mapM (processOneSapling s2) y
where processOneSapling sx =
withObject "Sapling" $ \oS -> do
oS' <- oS .: "addresses"
return $ map (ZcashAddress sx [Sapling] Nothing) oS'
processUnified u =
case u of
Nothing -> return []
Just z -> mapM processOneAccount z
where processOneAccount =
withObject "UAs" $ \uS -> do
acct <- uS .: "account"
uS' <- uS .: "addresses"
mapM (processUAs acct) uS'
where
processUAs a =
withObject "UAs" $ \v -> do
addr <- v .: "address"
p <- v .: "receiver_types"
return $ ZcashAddress MnemonicSeed p a addr
-- | Type for modelling the different address sources for Zcash 5.0.0
data AddressSource
= LegacyRandom
| Imported
| ImportedWatchOnly
| KeyPool
| LegacySeed
| MnemonicSeed
deriving (Read, Show, Eq, Generic, ToJSON)
instance FromJSON AddressSource where
parseJSON =
withText "AddressSource" $ \case
"legacy_random" -> return LegacyRandom
"imported" -> return Imported
"imported_watchonly" -> return ImportedWatchOnly
"keypool" -> return KeyPool
"legacy_hdseed" -> return LegacySeed
"mnemonic_seed" -> return MnemonicSeed
_ -> fail "Not a known address source"
data ZcashPool
= Transparent
| Sprout
| Sapling
| Orchard
deriving (Show, Eq, Generic, ToJSON)
instance FromJSON ZcashPool where
parseJSON =
withText "ZcashPool" $ \case
"p2pkh" -> return Transparent
"sprout" -> return Sprout
"sapling" -> return Sapling
"orchard" -> return Orchard
_ -> fail "Not a known Zcash pool"
data ZcashAddress =
ZcashAddress
{ source :: AddressSource
, pool :: [ZcashPool]
, account :: Maybe Integer
, addy :: T.Text
}
deriving (Eq)
instance Show ZcashAddress where
show (ZcashAddress s p i a) =
T.unpack (T.take 8 a) ++
"..." ++ T.unpack (T.takeEnd 8 a) ++ " Pools: " ++ show p
-- | Helper function to turn a hex-encoded memo strings to readable text
decodeHexText :: String -> T.Text
decodeHexText h = E.decodeUtf8With lenientDecode $ BS.pack $ hexRead h
where
hexRead hexText
| null chunk = []
| otherwise =
fromIntegral (read ("0x" <> chunk)) : hexRead (drop 2 hexText)
where
chunk = take 2 hexText
-- | Helper function to turn a string into a hex-encoded string
encodeHexText :: T.Text -> String
encodeHexText t = T.unpack . toText . fromBytes $ E.encodeUtf8 t
-- Types for the ZGo database documents
-- | Type to model a country for the database's country list
data Country =
Country
{ _id :: String
, name :: T.Text
, code :: T.Text
}
deriving (Eq, Show, Generic, ToJSON)
parseCountryBson :: B.Document -> Maybe Country
parseCountryBson d = do
i <- B.lookup "_id" d
n <- B.lookup "name" d
c <- B.lookup "code" d
pure $ Country (show (i :: B.ObjectId)) n c
zToZGoTx :: ZcashTx -> ZGoTx
zToZGoTx (ZcashTx t a aZ bh bt c conf m) = do
let r =
mkRegex
".*ZGO::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12})\\sReply-To:\\s(zs[a-z0-9]{76}).*"
let p =
mkRegex
".*ZGOp::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12}).*"
let y =
mkRegex
".*MSG\\s(zs[a-z0-9]{76})\\s+ZGO::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12}).*"
let reg = matchAllText r (T.unpack m)
let reg2 = matchAllText p (T.unpack m)
let reg3 = matchAllText y (T.unpack m)
if not (null reg)
then do
let sess = T.pack (fst $ head reg ! 1)
let nAddy = T.pack (fst $ head reg ! 2)
ZGoTx Nothing nAddy sess conf bt a t m
else do
if not (null reg2)
then do
let sess = T.pack (fst $ head reg2 ! 1)
ZGoTx Nothing "" sess conf bt a t m
else do
if not (null reg3)
then do
let sess = T.pack (fst $ head reg3 ! 2)
let nAddy = T.pack (fst $ head reg3 ! 1)
ZGoTx Nothing nAddy sess conf bt a t m
else ZGoTx Nothing "" "" conf bt a t m
-- |Type to model a price in the ZGo database
data ZGoPrice =
ZGoPrice
{ _id :: String
, currency :: T.Text
, price :: Double
, timestamp :: UTCTime
}
deriving (Eq, Show, Generic, ToJSON)
parseZGoPrice :: B.Document -> Maybe ZGoPrice
parseZGoPrice d = do
i <- B.lookup "_id" d
c <- B.lookup "currency" d
p <- B.lookup "price" d
t <- B.lookup "timestamp" d
pure $ ZGoPrice (show (i :: B.ObjectId)) c p t
-- | Type for the CoinGecko response
newtype CoinGeckoPrices =
CoinGeckoPrices [(T.Text, Double)]
deriving (Eq, Show)
instance FromJSON CoinGeckoPrices where
parseJSON =
withObject "CoinGeckoPrices" $ \obj -> do
z <- obj .: "zcash"
pure $ CoinGeckoPrices (HM.toList z)
-- Functions for querying the ZGo database
-- | Function to query DB for countries list
listCountries :: Action IO [Document]
listCountries = rest =<< find (select [] "countries")
sendPin ::
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
, Data.Aeson.Array
(V.fromList
[ object
[ "address" .= addr
, "amount" .= (0.00000001 :: Double)
, "memo" .= encodeHexText ("ZGo PIN: " <> pin)
]
])
]
r <- makeZcashCall nodeUser nodePwd "z_sendmany" pd
let sCode = getResponseStatus (r :: Response Object)
if sCode == ok200
then return "Pin sent!"
else return "Pin sending failed :("
-- | Function to create user from ZGoTx
addUser ::
BS.ByteString
-> BS.ByteString
-> Pipe
-> T.Text
-> T.Text
-> Maybe ZGoTx
-> Action IO ()
addUser _ _ _ _ _ Nothing = return () --`debug` "addUser got Nothing"
addUser nodeUser nodePwd p db node (Just tx) = do
isNew <- liftIO $ isUserNew p db tx
when isNew $ do
let newPin = unsafePerformIO (generatePin (fromIntegral $ blocktime tx))
_ <- sendPin nodeUser nodePwd node (address tx) newPin
insert_
"users"
[ "address" =: address tx
, "session" =: session tx
, "blocktime" =: blocktime tx
, "pin" =: newPin
, "validated" =: False
]
-- | Function to query DB for transactions with less than 10 confirmations
findPending :: String -> Action IO [Document]
findPending s =
rest =<<
find
(select ["session" =: s, "confirmations" =: ["$lt" =: (3 :: Integer)]] "txs")
-- | Function to query DB for price by currency
findPrice :: String -> Action IO (Maybe Document)
findPrice c = findOne (select ["currency" =: c] "prices")
-- | Function to update prices in ZGo db
updatePrices :: CoinGeckoPrices -> [Action IO ()]
updatePrices (CoinGeckoPrices []) = []
updatePrices (CoinGeckoPrices x) = do
updateOnePrice (head x) : updatePrices (CoinGeckoPrices (tail x))
-- | Function to update one price in ZGo db
updateOnePrice :: (T.Text, Double) -> Action IO ()
updateOnePrice (c, v) = do
t <- liftIO getCurrentTime
upsert
(select ["currency" =: c] "prices")
["currency" =: c, "price" =: v, "timestamp" =: t]
-- | Function to upsert ZGoTxs into the given collection
upsertZGoTx :: T.Text -> ZGoTx -> Action IO ()
upsertZGoTx coll t = do
upsert (select ["txid" =: txid t] coll) (encodeZGoTxBson t)
-- | Function to upsert payment
upsertPayment :: Pipe -> T.Text -> ZGoTx -> IO ()
upsertPayment pipe dbName p = do
zecData <- access pipe master dbName (findPrice "usd")
let zecPrice = parseZGoPrice =<< zecData
case zecPrice of
Nothing -> error "Failed to fetch ZEC price"
Just zp -> do
let delta = sessionCalc (price zp) (amount p)
let payTx =
Payment
Nothing
delta
False
(address p)
(session p)
(blocktime p)
(amount p)
(txid p)
(memo p)
let payment = val payTx
case payment of
Doc d ->
access pipe master dbName $
upsert (select ["txid" =: txid p] "payments") d
_ -> return ()
-- | Main API routes
routes :: Pipe -> Config -> ScottyM ()
routes pipe config = do
let run = access pipe master (c_dbName config)
let passkey = c_passkey config
let nodeUser = c_nodeUser config
let nodePwd = c_nodePwd config
let nodeAddress = c_nodeAddress config
middleware $
cors $
const $
Just
simpleCorsResourcePolicy
{ corsRequestHeaders = ["Authorization", "Content-Type"]
, corsMethods = "DELETE" : simpleMethods
--, corsOrigins = Nothing
}
middleware $
basicAuth
(\u p -> return $ u == "user" && secureMemFromByteString p == passkey)
"ZGo Backend"
--Get list of countries for UI
get "/api/countries" $ do
countries <- liftIO $ run listCountries
case countries of
[] -> do
status noContent204
_ -> do
Web.Scotty.json
(object
[ "message" .= ("Country data found" :: String)
, "countries" .= toJSON (map parseCountryBson countries)
])
--Get Xero credentials
get "/api/xero" $ do
xeroConfig <- liftIO $ run findXero
case xeroConfig of
Nothing -> status noContent204
Just x -> do
let xConfig = cast' (Doc x)
case xConfig of
Nothing -> status noContent204
Just c -> do
status ok200
Web.Scotty.json
(object
[ "message" .= ("Xero config found!" :: String)
, "xeroConfig" .= toJSON (c :: Xero)
])
get "/api/xerotoken" $ do
code <- param "code"
address <- param "address"
xeroConfig <- liftIO $ run findXero
case xeroConfig of
Nothing -> status noContent204
Just x -> do
let xConfig = cast' (Doc x)
case xConfig of
Nothing -> status noContent204
Just c -> do
res <-
liftIO $ requestXeroToken pipe (c_dbName config) c code address
if res
then status ok200
else status noContent204
get "/api/invdata" $ do
inv <- param "inv"
oAddress <- param "address"
xeroConfig <- liftIO $ run findXero
case xeroConfig of
Nothing -> do
status noContent204
text "Xero App credentials not found"
Just x -> do
let xConfig = cast' (Doc x)
case xConfig of
Nothing -> do
status noContent204
text "Xero App credentials corrupted"
Just c -> do
res <-
liftAndCatchIO $
requestXeroToken pipe (c_dbName config) c "none" oAddress
if res
then do
resInv <-
liftAndCatchIO $
getXeroInvoice pipe (c_dbName config) inv oAddress
case resInv of
Nothing -> do
status noContent204
text "Xero invoice not found"
Just xI -> do
status ok200
Web.Scotty.json (object ["invdata" .= toJSON xI])
else status noContent204
-- Get the xeroaccount code
get "/api/xeroaccount" $ do
oAdd <- param "address"
res <- liftIO $ run (findToken oAdd)
let c = cast' . Doc =<< res
case c of
Nothing -> status noContent204
Just c1 -> do
status ok200
Web.Scotty.json
(object
[ "message" .= ("Xero account code found" :: String)
, "code" .= t_code c1
])
-- Save the xeroaccount code
post "/api/xeroaccount" $ do
oAdd <- param "address"
c <- param "code"
liftAndCatchIO $ run (addAccCode oAdd c)
status accepted202
--Get user associated with session
get "/api/user" $ do
sess <- param "session"
user <- liftIO $ run (findUser sess)
case user of
Nothing -> status noContent204
Just u ->
Web.Scotty.json
(object
[ "message" .= ("User found" :: String)
, "user" .= toJSON (parseUserBson u)
])
--Validate user, updating record
post "/api/validateuser" $ do
providedPin <- param "pin"
sess <- param "session"
user <- liftIO $ run (findUser sess)
case user of
Nothing -> status noContent204 --`debug` "No user match"
Just u -> do
let parsedUser = parseUserBson u
case parsedUser of
Nothing -> status noContent204 --`debug` "Couldn't parse user"
Just pUser -> do
let ans = upin pUser == T.pack providedPin
if ans
then do
liftIO $ run (validateUser sess)
status accepted202
else status noContent204 --`debug` ("Pins didn't match: " ++ providedPin ++ " " ++ T.unpack (upin pUser))
--Delete user
Web.Scotty.delete "/api/user/:id" $ do
userId <- param "id"
let r = mkRegex "^[a-f0-9]{24}$"
if matchTest r userId
then do
liftIO $ run (deleteUser userId)
status ok200
else status noContent204
--Get current blockheight from Zcash node
get "/api/blockheight" $ do
blockInfo <- makeZcashCall nodeUser nodePwd "getblock" ["-1"]
let content = getResponseBody blockInfo :: RpcResponse Block
if isNothing (err content)
then do
status ok200
Web.Scotty.json $ fromMaybe (Block 0 0) (result content)
else do
status internalServerError500
--Get the ZGo node's shielded address
get "/api/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress])
--Get owner by address
get "/api/owner" $ do
addr <- param "address"
owner <- liftIO $ run (findOwner addr)
case owner of
Nothing -> status noContent204
Just o -> do
let pOwner = cast' (Doc o)
case pOwner of
Nothing -> status internalServerError500
Just q -> do
status ok200
Web.Scotty.json
(object
[ "message" .= ("Owner found!" :: String)
, "owner" .= toJSON (q :: Owner)
])
get "/api/ownerid" $ do
id <- param "id"
owner <- liftIO $ run (findOwnerById id)
case owner of
Nothing -> status noContent204
Just o -> do
let pOwner = cast' (Doc o)
case pOwner of
Nothing -> status internalServerError500
Just q -> do
status ok200
Web.Scotty.json
(object
[ "message" .= ("Owner found!" :: String)
, "owner" .= toJSON (q :: Owner)
])
--Upsert owner to DB
post "/api/owner" $ do
o <- jsonData
let q = payload (o :: Payload Owner)
known <- liftIO $ listAddresses nodeUser nodePwd
if not (opayconf q)
then do
_ <- liftIO $ run (upsertOwner q)
status created201
else do
if oaddress q `elem` map addy known
then do
_ <- liftIO $ run (upsertOwner q)
status created201
else do
vkInfo <-
makeZcashCall
nodeUser
nodePwd
"z_importviewingkey"
[Data.Aeson.String (oviewkey q), "no"]
let content = getResponseBody vkInfo :: RpcResponse Object
if isNothing (err content)
then do
_ <- liftIO $ run (upsertOwner q)
status created201
else do
status internalServerError500
--Get items associated with the given address
get "/api/items" $ do
addr <- param "address"
items <- liftIO $ run (findItems addr)
case items of
[] -> status noContent204
_ -> do
let pItems = map (cast' . Doc) items :: [Maybe Item]
status ok200
Web.Scotty.json
(object
["message" .= ("Items found!" :: String), "items" .= toJSON pItems])
--Upsert item
post "/api/item" $ do
i <- jsonData
let q = payload (i :: Payload Item)
_ <- liftIO $ run (upsertItem q)
status created201
--Delete item
Web.Scotty.delete "/api/item/:id" $ do
oId <- param "id"
let r = mkRegex "^[a-f0-9]{24}$"
if matchTest r oId
then do
liftIO $ run (deleteItem oId)
status ok200
else status noContent204
--Get price for Zcash
get "/api/price" $ do
curr <- param "currency"
pr <- liftIO $ run (findPrice curr)
case pr of
Nothing -> do
status noContent204
Just p -> do
Web.Scotty.json
(object
[ "message" .= ("Price found!" :: String)
, "price" .= toJSON (parseZGoPrice p)
])
--Get all closed orders for the address
get "/api/allorders" $ do
addr <- param "address"
myOrders <- liftIO $ run (findAllOrders addr)
case myOrders of
[] -> status noContent204
_ -> do
let pOrders = map (cast' . Doc) myOrders :: [Maybe ZGoOrder]
status ok200
Web.Scotty.json
(object
[ "message" .= ("Orders found!" :: String)
, "orders" .= toJSON pOrders
])
--Get order by id for receipts
get "/api/order/:id" $ do
oId <- param "id"
let r = mkRegex "^[a-f0-9]{24}$"
if matchTest r oId
then do
myOrder <- liftIO $ run (findOrderById oId)
case myOrder of
Nothing -> status noContent204
Just o -> do
let o' = cast' (Doc o)
case o' of
Nothing -> status internalServerError500
Just pOrder -> do
status ok200
Web.Scotty.json
(object
[ "message" .= ("Order found!" :: String)
, "order" .= toJSON (pOrder :: ZGoOrder)
])
else status noContent204
--Get order by session
get "/api/order" $ do
sess <- param "session"
myOrder <- liftIO $ run (findOrder sess)
case myOrder of
Nothing -> status noContent204
Just o -> do
let o' = cast' (Doc o)
case o' of
Nothing -> status internalServerError500
Just pOrder -> do
status ok200
Web.Scotty.json
(object
[ "message" .= ("Order found!" :: String)
, "order" .= toJSON (pOrder :: ZGoOrder)
])
--Upsert xero order
post "/api/orderx" $ do
newOrder <- jsonData
let q = payload (newOrder :: Payload ZGoOrder)
_ <- liftIO $ run (upsertXeroOrder q)
myOrder <-
liftIO $
run (findXeroOrder (qaddress q) (qexternalInvoice q) (qshortCode q))
case myOrder of
Nothing -> status noContent204
Just o -> do
let o' = cast' (Doc o)
case o' of
Nothing -> status internalServerError500
Just pOrder -> do
status created201
Web.Scotty.json
(object
[ "message" .= ("Order found!" :: String)
, "order" .= toJSON (pOrder :: ZGoOrder)
])
-- Upsert order
post "/api/order" $ do
newOrder <- jsonData
let q = payload (newOrder :: Payload ZGoOrder)
_ <- liftIO $ run (upsertOrder q)
status created201
--Delete order
Web.Scotty.delete "/api/order/:id" $ do
oId <- param "id"
liftIO $ run (deleteOrder oId)
status ok200
-- | Make a Zcash RPC call
makeZcashCall ::
(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
forever $ threadDelay (secs * 1000000) >> func
-- |Function to query the CoinGecko API for the price of Zcash
getZcashPrices :: IO (Response CoinGeckoPrices)
getZcashPrices = do
let priceRequest =
setRequestQueryString
[ ("ids", Just "zcash")
, ("vs_currencies", Just "usd,gbp,eur,cad,aud,nzd")
] $
setRequestPort 443 $
setRequestSecure True $
setRequestHost "api.coingecko.com" $
setRequestPath "/api/v3/simple/price" defaultRequest
httpJSON priceRequest
-- | Function to update the Zcash prices in the ZGo db
checkZcashPrices :: Pipe -> T.Text -> IO ()
checkZcashPrices p db = do
q <- getZcashPrices
mapM_ (access p master db) (updatePrices (getResponseBody q))
-- | Function to search for transactions for an address
listTxs ::
BS.ByteString
-> BS.ByteString
-> T.Text
-> Integer
-> IO (Either T.Text [ZcashTx])
listTxs user pwd a confs = do
res <-
liftIO $
makeZcashCall
user
pwd
"z_listreceivedbyaddress"
[Data.Aeson.String a, Data.Aeson.Number $ Scientific.scientific confs 0]
let content = getResponseBody res :: RpcResponse [ZcashTx]
case err content of
Nothing ->
return $ Right $ filter (not . zchange) $ fromMaybe [] $ result content
Just e -> return $ Left $ "Error reading transactions: " <> emessage e
-- | Function to check the ZGo full node for new txs
scanZcash :: Config -> Pipe -> IO ()
scanZcash config pipe = do
myTxs <-
listTxs (c_nodeUser config) (c_nodePwd config) (c_nodeAddress config) 1
case myTxs of
Right txs -> do
let r =
mkRegex
".*ZGO::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12})\\sReply-To:\\s(zs[a-z0-9]{76}).*"
let p =
mkRegex
".*ZGOp::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12}).*"
let y =
mkRegex
".*MSG\\s(zs[a-z0-9]{76})\\s+ZGO::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12}).*"
let k = map zToZGoTx (filter (isRelevant r) txs)
mapM_ (access pipe master (c_dbName config) . upsertZGoTx "txs") k
let j = map zToZGoTx (filter (isRelevant p) txs)
mapM_ (upsertPayment pipe (c_dbName config)) j
let l = map zToZGoTx (filter (isRelevant y) txs)
mapM_ (access pipe master (c_dbName config) . upsertZGoTx "txs") l
Left e -> do
putStrLn $ "Error scanning node transactions: " ++ T.unpack e
return ()
-- | Function to filter transactions
isRelevant :: Text.Regex.Regex -> ZcashTx -> Bool
isRelevant re t
| zconfirmations t < 10 && (matchTest re . T.unpack . zmemo) t = True
| otherwise = False
-- | Function to scan loaded viewing keys for payments
scanPayments :: Config -> Pipe -> IO ()
scanPayments config pipe = do
shops <- listAddresses (c_nodeUser config) (c_nodePwd config)
mapM_ (findPaidOrders config pipe) shops
where
findPaidOrders :: Config -> Pipe -> ZcashAddress -> IO ()
findPaidOrders c p z = do
paidTxs <- listTxs (c_nodeUser c) (c_nodePwd c) (addy z) 5
case paidTxs of
Right txs -> do
let r = mkRegex ".*ZGo Order::([0-9a-fA-F]{24}).*"
let k = filter (isRelevant r) txs
let j = map (getOrderId r) k
mapM_ (access p master (c_dbName config) . markOrderPaid) j
Left e -> putStrLn $ T.unpack e
getOrderId :: Text.Regex.Regex -> ZcashTx -> (String, Double)
getOrderId re t = do
let reg = matchAllText re (T.unpack $ zmemo t)
if not (null reg)
then (fst $ head reg ! 1, zamount t)
else ("", 0)
-- | RPC methods
-- | List addresses with viewing keys loaded
listAddresses :: BS.ByteString -> BS.ByteString -> IO [ZcashAddress]
listAddresses user pwd = do
response <- makeZcashCall user pwd "listaddresses" []
let rpcResp = getResponseBody response
case rpcResp of
Nothing -> fail "Couldn't parse node response"
Just res -> do
let addys = fromMaybe [] $ result res :: [AddressGroup]
let addList = concatMap getAddresses addys
return $ filter (\a -> source a == ImportedWatchOnly) addList
-- | Helper function to extract addresses from AddressGroups
getAddresses :: AddressGroup -> [ZcashAddress]
getAddresses ag = agtransparent ag <> agsapling ag <> agunified ag
-- | Function to generate users from login txs
updateLogins :: Pipe -> Config -> IO ()
updateLogins pipe config = do
let db = c_dbName config
let nodeUser = c_nodeUser config
let nodePwd = c_nodePwd config
let addr = c_nodeAddress config
results <-
access
pipe
master
db
(rest =<<
find (select ["confirmations" =: ["$lt" =: (100 :: Integer)]] "txs"))
let parsed = map (cast' . Doc) results
mapM_
(access pipe master db . ZGoBackend.addUser nodeUser nodePwd pipe db addr)
parsed
-- | Function to mark owners as paid
checkPayments :: Pipe -> T.Text -> IO ()
checkPayments pipe db = do
qPayments <-
access pipe master db (rest =<< find (select ["done" =: False] "payments"))
let parsedPayments = map (cast' . Doc) qPayments
mapM_ (payOwner pipe db) parsedPayments
payOwner :: Pipe -> T.Text -> Maybe Payment -> IO ()
payOwner p d x =
case x of
Nothing -> return ()
Just k -> do
now <- getCurrentTime
if posixSecondsToUTCTime (fromInteger (pblocktime k + pdelta k)) <= now
then markPaymentDone p d k
else markOwnerPaid p d k
where markPaymentDone :: Pipe -> T.Text -> Payment -> IO ()
markPaymentDone pipe db pmt = do
_ <-
access
pipe
master
db
(modify
(select ["_id" =: p_id pmt] "payments")
["$set" =: ["done" =: True]])
return ()
markOwnerPaid :: Pipe -> T.Text -> Payment -> IO ()
markOwnerPaid pipe db pmt = do
user <- access pipe master db (findUser $ psession pmt)
let parsedUser = parseUserBson =<< user
let zaddy = maybe "" uaddress parsedUser
owner <- access pipe master db $ findOwner zaddy
let ownerId = o_id =<< (cast' . Doc) =<< owner
if pdelta pmt > 90000000
then do
_ <-
access
pipe
master
db
(modify
(select ["_id" =: ownerId] "owners")
[ "$set" =:
[ "paid" =: True
, "invoices" =: True
, "expiration" =:
posixSecondsToUTCTime
(fromInteger
(pblocktime pmt + pdelta pmt - 90000000))
]
])
markPaymentDone pipe db pmt
else do
_ <-
access
pipe
master
db
(modify
(select ["_id" =: ownerId] "owners")
[ "$set" =:
[ "paid" =: True
, "expiration" =:
posixSecondsToUTCTime
(fromInteger (pblocktime pmt + pdelta pmt))
]
])
markPaymentDone pipe db pmt
expireOwners :: Pipe -> T.Text -> IO ()
expireOwners pipe db = do
now <- getCurrentTime
_ <-
access
pipe
master
db
(modify
(select ["expiration" =: ["$lt" =: now]] "owners")
["$set" =: ["paid" =: False]])
return ()
debug = flip trace