zgo-backend/src/ZGoBackend.hs

1518 lines
50 KiB
Haskell
Raw Normal View History

2022-04-22 16:15:23 +00:00
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
2022-04-22 16:15:23 +00:00
module ZGoBackend where
2023-01-26 18:13:17 +00:00
import qualified BLAKE3 as BLK
2022-07-12 21:08:27 +00:00
import Config
2022-04-30 12:59:49 +00:00
import Control.Concurrent (forkIO, threadDelay)
2022-12-26 14:20:50 +00:00
import Control.Exception (try)
2022-04-22 16:15:23 +00:00
import Control.Monad
import Control.Monad.IO.Class
import Data.Aeson
2022-04-30 12:59:49 +00:00
import Data.Array
2022-04-22 16:15:23 +00:00
import qualified Data.Bson as B
2023-01-26 18:13:17 +00:00
import qualified Data.ByteArray as BA
2022-04-30 12:59:49 +00:00
import qualified Data.ByteString as BS
2022-12-01 20:36:06 +00:00
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as C
2022-04-22 16:15:23 +00:00
import Data.Char
import qualified Data.HashMap.Strict as HM
2022-07-07 15:33:53 +00:00
import Data.HexString
2022-05-03 13:59:29 +00:00
import Data.Maybe
2022-07-22 16:04:15 +00:00
import qualified Data.Scientific as Scientific
2022-04-30 12:59:49 +00:00
import Data.SecureMem
2022-04-22 16:15:23 +00:00
import qualified Data.Text as T
2022-07-07 15:13:33 +00:00
import qualified Data.Text.Encoding as E
import Data.Text.Encoding.Error (lenientDecode)
2022-04-30 12:59:49 +00:00
import qualified Data.Text.Lazy as L
2022-04-22 16:15:23 +00:00
import Data.Time.Clock
2022-05-17 17:47:27 +00:00
import Data.Time.Clock.POSIX
2022-12-01 20:36:06 +00:00
import Data.Time.Format
2022-05-11 20:04:46 +00:00
import Data.Typeable
2023-03-10 21:31:47 +00:00
import qualified Data.UUID as U
2022-04-30 12:59:49 +00:00
import qualified Data.Vector as V
2022-08-20 13:09:46 +00:00
import Data.Vector.Internal.Check (doChecks)
2022-05-11 20:04:46 +00:00
import Data.Word
2022-04-22 16:15:23 +00:00
import Database.MongoDB
2022-05-03 13:59:29 +00:00
import Debug.Trace
2022-04-22 16:15:23 +00:00
import GHC.Generics
2022-05-12 19:59:29 +00:00
import Item
2023-02-02 21:14:28 +00:00
import LangComponent
2022-04-30 12:59:49 +00:00
import Network.HTTP.Simple
import Network.HTTP.Types.Status
2023-05-08 16:21:09 +00:00
import Network.Wai (Application, Middleware, Request(..), pathInfo, responseLBS)
2022-05-17 17:47:27 +00:00
import Network.Wai.Middleware.Cors
2022-04-30 12:59:49 +00:00
import Network.Wai.Middleware.HttpAuth
import Numeric
2022-05-11 20:04:46 +00:00
import Order
import Owner
2022-05-17 17:47:27 +00:00
import Payment
2022-04-30 12:59:49 +00:00
import System.IO.Unsafe
import System.Random
import Test.QuickCheck
import Test.QuickCheck.Instances
2022-08-10 15:17:47 +00:00
import Test.QuickCheck.Property (Result(ok))
2023-03-10 21:31:47 +00:00
import Text.Megaparsec (runParser)
2022-04-30 12:59:49 +00:00
import Text.Regex
import Text.Regex.Base
2022-05-11 20:04:46 +00:00
import User
2022-04-30 12:59:49 +00:00
import Web.Scotty
2022-11-14 21:56:30 +00:00
import WooCommerce
2022-08-10 15:17:47 +00:00
import Xero
2022-05-11 20:04:46 +00:00
import ZGoTx
2022-04-22 16:15:23 +00:00
-- Models for API objects
-- | A type to model Zcash RPC calls
data RpcCall =
RpcCall
{ jsonrpc :: T.Text
, callId :: T.Text
, method :: T.Text
2022-04-30 12:59:49 +00:00
, parameters :: [Data.Aeson.Value]
2022-04-22 16:15:23 +00:00
}
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
2022-04-22 16:15:23 +00:00
, respId :: T.Text
, result :: Maybe r
2022-04-22 16:15:23 +00:00
}
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
2022-05-17 17:47:27 +00:00
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
2022-04-22 16:15:23 +00:00
-- | 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
2022-04-30 12:59:49 +00:00
{ ztxid :: T.Text
, zamount :: Double
, zamountZat :: Integer
, zblockheight :: Integer
, zblocktime :: Integer
, zchange :: Bool
, zconfirmations :: Integer
, zmemo :: T.Text
2022-04-22 16:15:23 +00:00
}
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"
2022-07-22 16:04:15 +00:00
c <- obj .:? "change"
2022-04-22 16:15:23 +00:00
conf <- obj .: "confirmations"
m <- obj .: "memo"
2022-04-30 12:59:49 +00:00
pure $
ZcashTx
t
a
aZ
bh
bt
2022-07-22 16:04:15 +00:00
(fromMaybe False c)
2022-04-30 12:59:49 +00:00
conf
2022-07-22 16:04:15 +00:00
(T.filter (/= '\NUL') $ decodeHexText m)
2022-04-22 16:15:23 +00:00
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
]
2022-04-30 12:59:49 +00:00
instance Arbitrary ZcashTx where
arbitrary = do
a <- arbitrary
aZ <- arbitrary
t <- arbitrary
bh <- arbitrary
bt <- arbitrary
c <- arbitrary
cm <- arbitrary
2022-05-11 20:04:46 +00:00
ZcashTx a aZ t bh bt c cm <$> arbitrary
2022-04-30 12:59:49 +00:00
-- | 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
2022-04-22 16:15:23 +00:00
-- | Helper function to turn a hex-encoded memo strings to readable text
2022-07-07 15:13:33 +00:00
decodeHexText :: String -> T.Text
decodeHexText h = E.decodeUtf8With lenientDecode $ BS.pack $ hexRead h
2022-04-22 16:15:23 +00:00
where
2022-07-07 15:13:33 +00:00
hexRead hexText
| null chunk = []
| otherwise =
fromIntegral (read ("0x" <> chunk)) : hexRead (drop 2 hexText)
where
chunk = take 2 hexText
2022-04-22 16:15:23 +00:00
2022-04-30 12:59:49 +00:00
-- | Helper function to turn a string into a hex-encoded string
2022-07-07 15:33:53 +00:00
encodeHexText :: T.Text -> String
encodeHexText t = T.unpack . toText . fromBytes $ E.encodeUtf8 t
2022-04-30 12:59:49 +00:00
2022-04-22 16:15:23 +00:00
-- 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
2022-04-30 12:59:49 +00:00
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}).*"
2022-08-26 22:10:59 +00:00
let y =
mkRegex
2022-08-29 20:35:24 +00:00
".*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}).*"
2022-04-30 12:59:49 +00:00
let reg = matchAllText r (T.unpack m)
let reg2 = matchAllText p (T.unpack m)
2022-08-26 22:10:59 +00:00
let reg3 = matchAllText y (T.unpack m)
2022-04-30 12:59:49 +00:00
if not (null reg)
then do
2022-05-11 20:04:46 +00:00
let sess = T.pack (fst $ head reg ! 1)
2022-07-22 16:04:15 +00:00
let nAddy = T.pack (fst $ head reg ! 2)
ZGoTx Nothing nAddy sess conf bt a t m
2022-04-30 12:59:49 +00:00
else do
if not (null reg2)
then do
2022-05-11 20:04:46 +00:00
let sess = T.pack (fst $ head reg2 ! 1)
2022-05-17 17:47:27 +00:00
ZGoTx Nothing "" sess conf bt a t m
2022-08-26 22:10:59 +00:00
else do
if not (null reg3)
then do
2022-08-29 15:33:38 +00:00
let sess = T.pack (fst $ head reg3 ! 2)
let nAddy = T.pack (fst $ head reg3 ! 1)
2022-08-26 22:10:59 +00:00
ZGoTx Nothing nAddy sess conf bt a t m
else ZGoTx Nothing "" "" conf bt a t m
2022-04-22 16:15:23 +00:00
2023-03-14 15:17:31 +00:00
zToZGoTx' :: Config -> Pipe -> ZcashTx -> IO ()
zToZGoTx' config pipe (ZcashTx t a aZ bh bt c conf m) = do
when (conf < 100) $ do
let zM = runParser pZGoMemo (T.unpack t) m
case zM of
Right zM' -> do
let tx =
ZGoTx
Nothing
(fromMaybe "" $ m_address zM')
(maybe "" U.toText $ m_session zM')
conf
bt
a
t
m
if m_payment zM'
then upsertPayment pipe (c_dbName config) tx
else access pipe master (c_dbName config) $ upsertZGoTx "txs" tx
Left e -> error "Failed to parse ZGo memo"
2023-03-10 21:31:47 +00:00
2022-04-22 16:15:23 +00:00
-- |Type to model a price in the ZGo database
data ZGoPrice =
ZGoPrice
{ _id :: String
, currency :: T.Text
, price :: Double
2022-05-03 13:59:29 +00:00
, timestamp :: UTCTime
2022-04-22 16:15:23 +00:00
}
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
2022-05-03 13:59:29 +00:00
pure $ ZGoPrice (show (i :: B.ObjectId)) c p t
2022-04-22 16:15:23 +00:00
-- | 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")
2022-05-19 17:56:56 +00:00
sendPin ::
BS.ByteString
-> BS.ByteString
-> T.Text
-> T.Text
-> T.Text
-> Action IO String
sendPin nodeUser nodePwd nodeAddress addr pin = do
2022-05-24 15:20:10 +00:00
let pd =
2022-04-30 12:59:49 +00:00
[ Data.Aeson.String nodeAddress
, Data.Aeson.Array
(V.fromList
[ object
[ "address" .= addr
, "amount" .= (0.00000001 :: Double)
2022-07-07 15:33:53 +00:00
, "memo" .= encodeHexText ("ZGo PIN: " <> pin)
2022-04-30 12:59:49 +00:00
]
])
]
2023-04-28 18:05:02 +00:00
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 Object)
if sCode == ok200
then return "Pin sent!"
else return "Pin sending failed :("
Left ex ->
return $ "Failed to send tx to node :(" ++ show (ex :: HttpException)
2022-04-22 16:15:23 +00:00
2022-05-11 20:04:46 +00:00
-- | Function to create user from ZGoTx
2022-05-19 17:56:56 +00:00
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
2022-05-11 20:04:46 +00:00
isNew <- liftIO $ isUserNew p db tx
when isNew $ do
2023-02-01 18:49:33 +00:00
newPin <- liftIO generatePin
_ <- sendPin nodeUser nodePwd node (address tx) (T.pack newPin)
2023-01-26 18:13:17 +00:00
let pinHash =
BLK.hash
2023-02-01 18:49:33 +00:00
[ BA.pack . BS.unpack . C.pack . T.unpack $
T.pack newPin <> session tx :: BA.Bytes
2023-01-26 18:13:17 +00:00
]
2022-05-11 20:04:46 +00:00
insert_
"users"
[ "address" =: address tx
, "session" =: session tx
, "blocktime" =: blocktime tx
2023-01-26 18:13:17 +00:00
, "pin" =:
(T.pack . show $ (pinHash :: BLK.Digest BLK.DEFAULT_DIGEST_LEN))
2022-05-11 20:04:46 +00:00
, "validated" =: False
]
2022-04-22 16:15:23 +00:00
-- | Function to query DB for transactions with less than 10 confirmations
findPending :: String -> Action IO [Document]
findPending s =
rest =<<
find
2022-04-30 12:59:49 +00:00
(select ["session" =: s, "confirmations" =: ["$lt" =: (3 :: Integer)]] "txs")
2022-04-22 16:15:23 +00:00
-- | 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]
2022-04-30 12:59:49 +00:00
-- | 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)
2022-08-26 22:10:59 +00:00
-- | 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
2023-05-02 19:40:26 +00:00
Doc d -> do
results <-
access
pipe
master
dbName
(rest =<< find (select ["txid" =: txid p] "payments"))
when (null results) $
access pipe master dbName $
upsert (select ["txid" =: txid p] "payments") d
2022-08-26 22:10:59 +00:00
_ -> return ()
2022-12-01 20:36:06 +00:00
authSettings :: AuthSettings
authSettings = "ZGo Backend" {authIsProtected = needsAuth}
needsAuth :: Network.Wai.Request -> IO Bool
needsAuth req =
return $
case pathInfo req of
"api":_ -> True
_ -> False
2023-05-08 16:21:09 +00:00
zgoAuth :: Pipe -> T.Text -> Middleware
zgoAuth pipe dbName app req respond = do
let q = filter findSessionParam $ queryString req
isFenced <- needsAuth req
if isFenced
then do
if length q == 1
then do
isOk <- checkSession pipe dbName $ head q
if isOk
then app req respond
else respond $
responseLBS unauthorized401 [] "ZGo API access denied!"
else respond $ responseLBS unauthorized401 [] "ZGo API access denied!"
else app req respond
where
findSessionParam :: QueryItem -> Bool
findSessionParam (i, val) = i == "session"
checkSession ::
Pipe -> T.Text -> (BS.ByteString, Maybe BS.ByteString) -> IO Bool
checkSession p db (k, v) =
case v of
Just sessionId ->
isUserValid p db $ E.decodeUtf8With lenientDecode sessionId
Nothing -> return False
2022-05-19 14:52:17 +00:00
-- | Main API routes
2022-07-12 21:08:27 +00:00
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
2022-05-19 14:52:17 +00:00
middleware $
cors $
const $
Just
simpleCorsResourcePolicy
{ corsRequestHeaders = ["Authorization", "Content-Type"]
, corsMethods = "DELETE" : simpleMethods
2022-05-24 15:20:10 +00:00
--, corsOrigins = Nothing
2022-05-19 14:52:17 +00:00
}
middleware $
basicAuth
(\u p -> return $ u == "user" && secureMemFromByteString p == passkey)
2022-12-01 20:36:06 +00:00
authSettings
2023-05-08 16:21:09 +00:00
middleware $ zgoAuth pipe $ c_dbName config
2022-08-11 22:30:24 +00:00
--Get list of countries for UI
2022-05-19 14:52:17 +00:00
get "/api/countries" $ do
2022-09-22 20:20:10 +00:00
countries <- liftAndCatchIO $ run listCountries
2022-05-19 14:52:17 +00:00
case countries of
[] -> do
status noContent204
_ -> do
Web.Scotty.json
(object
[ "message" .= ("Country data found" :: String)
, "countries" .= toJSON (map parseCountryBson countries)
])
2022-08-11 22:30:24 +00:00
--Get Xero credentials
2022-08-10 15:17:47 +00:00
get "/api/xero" $ do
2022-09-22 20:20:10 +00:00
xeroConfig <- liftAndCatchIO $ run findXero
2022-08-10 15:17:47 +00:00
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)
])
2022-08-18 19:21:32 +00:00
get "/api/xerotoken" $ do
code <- param "code"
address <- param "address"
2022-09-22 20:20:10 +00:00
xeroConfig <- liftAndCatchIO $ run findXero
2022-08-18 19:21:32 +00:00
case xeroConfig of
Nothing -> status noContent204
Just x -> do
let xConfig = cast' (Doc x)
case xConfig of
Nothing -> status noContent204
Just c -> do
res <-
liftAndCatchIO $
requestXeroToken pipe (c_dbName config) c code address
2022-08-18 19:21:32 +00:00
if res
then status ok200
else status noContent204
2022-08-20 13:09:46 +00:00
get "/api/invdata" $ do
inv <- param "inv"
oAddress <- param "address"
2022-09-22 20:20:10 +00:00
xeroConfig <- liftAndCatchIO $ run findXero
2022-08-20 13:09:46 +00:00
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 <-
2022-09-06 19:01:14 +00:00
liftAndCatchIO $
requestXeroToken pipe (c_dbName config) c "none" oAddress
2022-08-20 13:09:46 +00:00
if res
then do
resInv <-
2022-08-23 14:55:04 +00:00
liftAndCatchIO $
getXeroInvoice pipe (c_dbName config) inv oAddress
2022-08-20 13:09:46 +00:00
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
2022-09-06 19:01:14 +00:00
-- Get the xeroaccount code
get "/api/xeroaccount" $ do
oAdd <- param "address"
2022-09-22 20:20:10 +00:00
res <- liftAndCatchIO $ run (findToken oAdd)
2022-09-06 19:01:14 +00:00
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)
2022-09-06 20:52:32 +00:00
status accepted202
-- Get the WooCommerce token
get "/api/wootoken" $ do
oid <- param "ownerid"
res <- liftAndCatchIO $ run (findWooToken (read oid))
let t1 = cast' . Doc =<< res
case t1 of
Nothing -> status noContent204
Just t -> do
status ok200
Web.Scotty.json
(object
[ "ownerid" .= show (w_owner t)
, "token" .= w_token t
, "siteurl" .= w_url t
])
post "/api/wootoken" $ do
oid <- param "ownerid"
res <- liftAndCatchIO $ run (findOwnerById oid)
let o1 = cast' . Doc =<< res
case o1 of
Nothing -> status noContent204
Just o -> do
liftAndCatchIO $ run (generateWooToken o)
status accepted202
2022-11-14 21:56:30 +00:00
-- Authenticate the WooCommerce plugin
2022-12-01 20:36:06 +00:00
get "/auth" $ do
2022-11-14 21:56:30 +00:00
oid <- param "ownerid"
t <- param "token"
siteurl <- param "siteurl"
res <- liftAndCatchIO $ run (findWooToken (read oid))
2022-12-01 20:36:06 +00:00
let c1 = cast' . Doc =<< res
case c1 of
2022-11-14 21:56:30 +00:00
Nothing -> do
status accepted202
Web.Scotty.json
(object
["authorized" .= False, "message" .= ("Owner not found" :: String)])
Just c ->
if t == w_token c
then if isNothing (w_url c)
then do
liftAndCatchIO $ run (addUrl c siteurl)
status ok200
Web.Scotty.json
(object
[ "authorized" .= True
, "message" .= ("Authorized!" :: String)
])
else do
if (E.decodeUtf8With lenientDecode .
B64.decodeLenient . C.pack . T.unpack)
siteurl ==
fromMaybe "" (w_url c)
then do
status ok200
Web.Scotty.json
(object
[ "authorized" .= True
, "message" .= ("Already authorized." :: String)
])
else do
status accepted202
Web.Scotty.json
(object
[ "authorized" .= False
, "message" .=
("ZGo shop already linked to " <>
fromMaybe "" (w_url c))
])
2022-11-14 21:56:30 +00:00
else do
status accepted202
Web.Scotty.json
(object
[ "authorized" .= False
, "message" .= ("Token mismatch" :: String)
])
2022-12-01 20:36:06 +00:00
get "/woopayment" $ do
oid <- param "ownerid"
t <- param "token"
ordId <- param "order_id"
date <- param "date"
curr <- param "currency"
amount <- param "amount"
sUrl <- param "siteurl"
2022-12-13 20:01:51 +00:00
orderKey <- param "orderkey"
2022-12-01 20:36:06 +00:00
res <- liftAndCatchIO $ run (findWooToken (read oid))
let c = cast' . Doc =<< res
case c of
Nothing -> do
status accepted202
Web.Scotty.json
(object ["message" .= ("Plugin not setup in ZGo" :: String)])
Just x ->
if t == w_token x &&
(E.decodeUtf8With lenientDecode . B64.decodeLenient . C.pack) sUrl ==
fromMaybe "" (w_url x)
then do
zecPriceDb <- liftAndCatchIO (run (findPrice curr))
let zecPrice = parseZGoPrice =<< zecPriceDb
case zecPrice of
Nothing -> do
status accepted202
Web.Scotty.json
(object ["message" .= ("Currency not supported" :: String)])
Just zP -> do
ownerDb <-
liftAndCatchIO $
run (findOwnerById (T.pack . show $ w_owner x))
let owner = cast' . Doc =<< ownerDb
case owner of
Nothing -> do
status accepted202
Web.Scotty.json
(object ["message" .= ("Owner not found" :: String)])
Just o ->
if opaid o
then do
let newOrder =
ZGoOrder
Nothing
(oaddress o)
2022-12-06 18:40:58 +00:00
(case o_id o of
Just o' -> "WC-" <> (T.pack . show $ o')
Nothing -> "")
2022-12-01 20:36:06 +00:00
(parseTimeOrError
True
defaultTimeLocale
"%Y-%0m-%0d"
date)
True
(T.pack curr)
(price zP)
0.0
0.0
[ LineItem
1.0
(oname o <> " order " <> ordId)
amount
]
False
2022-12-13 20:01:51 +00:00
(T.concat
[T.pack sUrl, "-", ordId, "-", orderKey])
2022-12-01 20:36:06 +00:00
""
newId <- liftAndCatchIO $ run (insertWooOrder newOrder)
status ok200
Web.Scotty.json (object ["order" .= show newId])
else do
status accepted202
Web.Scotty.json
(object
["message" .= ("ZGo shop not paid for" :: String)])
else do
status accepted202
Web.Scotty.json
(object ["message" .= ("Incorrect plugin config" :: String)])
2022-08-11 22:30:24 +00:00
--Get user associated with session
2022-05-19 14:52:17 +00:00
get "/api/user" $ do
sess <- param "session"
2022-09-22 20:20:10 +00:00
user <- liftAndCatchIO $ run (findUser sess)
2022-05-19 14:52:17 +00:00
case user of
Nothing -> status noContent204
Just u ->
Web.Scotty.json
(object
[ "message" .= ("User found" :: String)
, "user" .= toJSON (parseUserBson u)
])
--Validate user, updating record
2023-05-08 16:21:09 +00:00
post "/validateuser" $ do
2022-05-19 14:52:17 +00:00
providedPin <- param "pin"
sess <- param "session"
2023-01-27 17:01:05 +00:00
let pinHash =
BLK.hash
[ BA.pack . BS.unpack . C.pack . T.unpack $ providedPin <> sess :: BA.Bytes
]
2022-09-22 20:20:10 +00:00
user <- liftAndCatchIO $ run (findUser sess)
2022-05-19 14:52:17 +00:00
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
2023-01-27 17:01:05 +00:00
let ans =
upin pUser ==
(T.pack . show $
(pinHash :: BLK.Digest BLK.DEFAULT_DIGEST_LEN))
2022-05-19 14:52:17 +00:00
if ans
then do
2022-09-22 20:20:10 +00:00
liftAndCatchIO $ run (validateUser sess)
2022-05-19 14:52:17 +00:00
status accepted202
else status noContent204 --`debug` ("Pins didn't match: " ++ providedPin ++ " " ++ T.unpack (upin pUser))
2022-04-30 12:59:49 +00:00
--Delete user
2022-05-19 14:52:17 +00:00
Web.Scotty.delete "/api/user/:id" $ do
userId <- param "id"
2022-05-24 15:20:10 +00:00
let r = mkRegex "^[a-f0-9]{24}$"
if matchTest r userId
then do
2022-09-22 20:20:10 +00:00
liftAndCatchIO $ run (deleteUser userId)
2022-05-24 15:20:10 +00:00
status ok200
2022-05-24 18:10:01 +00:00
else status noContent204
2022-05-24 15:20:10 +00:00
--Get current blockheight from Zcash node
2022-05-19 14:52:17 +00:00
get "/api/blockheight" $ do
2023-04-28 18:05:02 +00:00
blockInfo <-
liftAndCatchIO $ 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
2022-05-24 15:20:10 +00:00
--Get the ZGo node's shielded address
2022-05-19 14:52:17 +00:00
get "/api/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress])
2022-05-24 15:20:10 +00:00
--Get owner by address
2022-05-19 14:52:17 +00:00
get "/api/owner" $ do
addr <- param "address"
2022-09-22 20:20:10 +00:00
owner <- liftAndCatchIO $ run (findOwner addr)
2022-05-19 14:52:17 +00:00
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)
2023-05-09 16:03:26 +00:00
, "owner" .=
object
2023-05-10 19:16:33 +00:00
[ "_id" .= (maybe "" show $ o_id q :: String)
2023-05-09 16:03:26 +00:00
, "address" .= oaddress q
, "name" .= oname q
, "currency" .= ocurrency q
, "tax" .= otax q
, "taxValue" .= otaxValue q
, "vat" .= ovat q
, "vatValue" .= ovatValue q
, "paid" .= opaid q
, "zats" .= ozats q
, "invoices" .= oinvoices q
, "expiration" .= oexpiration q
2023-05-10 15:42:40 +00:00
, "payconf" .= opayconf q
2023-05-09 16:03:26 +00:00
, "crmToken" .= ocrmToken q
]
2022-05-19 14:52:17 +00:00
])
2022-08-16 20:54:15 +00:00
get "/api/ownerid" $ do
id <- param "id"
2022-09-22 20:20:10 +00:00
owner <- liftAndCatchIO $ run (findOwnerById id)
2022-08-16 20:54:15 +00:00
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)
2023-05-09 16:03:26 +00:00
, "owner" .=
object
2023-05-10 19:16:33 +00:00
[ "_id" .= (maybe "" show $ o_id q :: String)
2023-05-09 16:03:26 +00:00
, "address" .= oaddress q
, "name" .= oname q
, "currency" .= ocurrency q
, "tax" .= otax q
, "taxValue" .= otaxValue q
, "vat" .= ovat q
, "vatValue" .= ovatValue q
, "paid" .= opaid q
, "zats" .= ozats q
, "invoices" .= oinvoices q
, "expiration" .= oexpiration q
2023-05-10 15:42:40 +00:00
, "payconf" .= opayconf q
2023-05-09 16:03:26 +00:00
, "crmToken" .= ocrmToken q
]
2022-08-16 20:54:15 +00:00
])
2022-05-24 15:20:10 +00:00
--Upsert owner to DB
2022-05-19 14:52:17 +00:00
post "/api/owner" $ do
2023-05-08 21:01:46 +00:00
s <- param "session"
u <- liftAndCatchIO $ run (findUser s)
2022-05-19 14:52:17 +00:00
o <- jsonData
2023-05-08 21:01:46 +00:00
now <- liftIO getCurrentTime
let q = payload (o :: Payload OwnerData)
case parseUserBson =<< u of
Nothing -> status internalServerError500
Just u' -> do
liftAndCatchIO $
run $
upsertOwner $
Owner
Nothing
(uaddress u')
(od_name q)
"usd"
False
0
False
0
(od_first q)
(od_last q)
(od_email q)
(od_street q)
(od_city q)
(od_state q)
(od_postal q)
(od_phone q)
(od_website q)
(od_country q)
False
False
False
now
False
""
""
status accepted202
2022-04-30 12:59:49 +00:00
--Get items associated with the given address
2022-05-19 14:52:17 +00:00
get "/api/items" $ do
addr <- param "address"
2022-09-22 20:20:10 +00:00
items <- liftAndCatchIO $ run (findItems addr)
2022-05-19 14:52:17 +00:00
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])
2022-04-30 12:59:49 +00:00
--Upsert item
2022-05-19 14:52:17 +00:00
post "/api/item" $ do
i <- jsonData
let q = payload (i :: Payload Item)
2022-09-22 20:20:10 +00:00
_ <- liftAndCatchIO $ run (upsertItem q)
2022-05-19 14:52:17 +00:00
status created201
2022-04-30 12:59:49 +00:00
--Delete item
2022-05-19 14:52:17 +00:00
Web.Scotty.delete "/api/item/:id" $ do
oId <- param "id"
2022-05-24 15:20:10 +00:00
let r = mkRegex "^[a-f0-9]{24}$"
if matchTest r oId
then do
2022-09-22 20:20:10 +00:00
liftAndCatchIO $ run (deleteItem oId)
2022-05-24 15:20:10 +00:00
status ok200
2022-05-24 18:10:01 +00:00
else status noContent204
2022-04-30 12:59:49 +00:00
--Get price for Zcash
2022-05-19 14:52:17 +00:00
get "/api/price" $ do
curr <- param "currency"
2022-09-22 20:20:10 +00:00
pr <- liftAndCatchIO $ run (findPrice curr)
2022-05-19 14:52:17 +00:00
case pr of
Nothing -> do
status noContent204
Just p -> do
Web.Scotty.json
(object
[ "message" .= ("Price found!" :: String)
, "price" .= toJSON (parseZGoPrice p)
])
2022-04-30 12:59:49 +00:00
--Get all closed orders for the address
2022-05-19 14:52:17 +00:00
get "/api/allorders" $ do
addr <- param "address"
2022-09-22 20:20:10 +00:00
myOrders <- liftAndCatchIO $ run (findAllOrders addr)
2022-05-19 14:52:17 +00:00
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
])
2022-04-30 12:59:49 +00:00
--Get order by id for receipts
2022-05-19 14:52:17 +00:00
get "/api/order/:id" $ do
oId <- param "id"
2022-05-24 15:20:10 +00:00
let r = mkRegex "^[a-f0-9]{24}$"
if matchTest r oId
then do
2022-09-22 20:20:10 +00:00
myOrder <- liftAndCatchIO $ run (findOrderById oId)
2022-05-24 15:20:10 +00:00
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)
])
2022-05-24 18:10:01 +00:00
else status noContent204
2022-04-30 12:59:49 +00:00
--Get order by session
2022-05-19 14:52:17 +00:00
get "/api/order" $ do
sess <- param "session"
2022-09-22 20:20:10 +00:00
myOrder <- liftAndCatchIO $ run (findOrder sess)
2022-05-19 14:52:17 +00:00
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)
])
2022-08-20 13:09:46 +00:00
--Upsert xero order
post "/api/orderx" $ do
newOrder <- jsonData
let q = payload (newOrder :: Payload ZGoOrder)
2022-08-21 21:59:23 +00:00
_ <- liftIO $ run (upsertXeroOrder q)
2022-08-20 13:09:46 +00:00
myOrder <-
2022-09-22 20:20:10 +00:00
liftAndCatchIO $
2022-08-20 13:09:46 +00:00
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
2022-05-19 14:52:17 +00:00
post "/api/order" $ do
newOrder <- jsonData
let q = payload (newOrder :: Payload ZGoOrder)
2022-09-22 20:20:10 +00:00
_ <- liftAndCatchIO $ run (upsertOrder q)
2022-05-19 14:52:17 +00:00
status created201
2022-05-11 20:04:46 +00:00
--Delete order
2022-05-19 14:52:17 +00:00
Web.Scotty.delete "/api/order/:id" $ do
oId <- param "id"
2022-09-22 20:20:10 +00:00
liftAndCatchIO $ run (deleteOrder oId)
2022-05-19 14:52:17 +00:00
status ok200
2023-02-02 21:14:28 +00:00
-- Get language for component
2023-05-10 19:58:31 +00:00
get "getloginlang" $ do
lang <- param "lang"
txtPack' <- liftAndCatchIO $ run (findLangComponent lang "login")
case cast' . Doc =<< txtPack' of
Nothing -> status noContent204
Just textPack -> do
status ok200
Web.Scotty.json $ toJSON (textPack :: LangComponent)
2023-02-02 21:14:28 +00:00
get "/api/getlang" $ do
component <- param "component"
lang <- param "lang"
txtPack' <- liftAndCatchIO $ run (findLangComponent lang component)
let txtPack = cast' . Doc =<< txtPack'
case txtPack of
Nothing -> status noContent204
Just tP -> do
status ok200
Web.Scotty.json $ toJSON (tP :: LangComponent)
2023-05-08 16:21:09 +00:00
{-post "/api/setlang" $ do-}
{-langComp <- jsonData-}
{-_ <--}
{-liftAndCatchIO $-}
{-mapM (run . loadLangComponent) (langComp :: [LangComponent])-}
{-status created201-}
2022-04-30 12:59:49 +00:00
2022-07-07 15:00:13 +00:00
-- | Make a Zcash RPC call
2022-04-30 12:59:49 +00:00
makeZcashCall ::
2022-05-19 17:56:56 +00:00
(MonadIO m, FromJSON a)
=> BS.ByteString
-> BS.ByteString
-> T.Text
-> [Data.Aeson.Value]
-> m (Response a)
makeZcashCall username password m p = do
2022-04-30 12:59:49 +00:00
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
2022-09-06 14:53:34 +00:00
[ ("ids", Just "zcash")
, ("vs_currencies", Just "usd,gbp,eur,cad,aud,nzd")
] $
2022-04-30 12:59:49 +00:00
setRequestPort 443 $
setRequestSecure True $
setRequestHost "api.coingecko.com" $
setRequestPath "/api/v3/simple/price" defaultRequest
httpJSON priceRequest
2022-05-03 13:59:29 +00:00
-- | Function to update the Zcash prices in the ZGo db
2022-04-30 12:59:49 +00:00
checkZcashPrices :: Pipe -> T.Text -> IO ()
checkZcashPrices p db = do
2022-12-26 14:20:50 +00:00
q <- try getZcashPrices
case q of
Left e -> print (e :: HttpException)
Right q1 -> mapM_ (access p master db) (updatePrices (getResponseBody q1))
2022-04-30 12:59:49 +00:00
2022-07-22 16:04:15 +00:00
-- | 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
2022-05-19 17:56:56 +00:00
res <-
2023-04-28 18:05:02 +00:00
try $
2022-05-19 17:56:56 +00:00
makeZcashCall
2022-07-22 16:04:15 +00:00
user
pwd
2022-05-19 17:56:56 +00:00
"z_listreceivedbyaddress"
2023-04-28 18:05:02 +00:00
[Data.Aeson.String a, Data.Aeson.Number $ Scientific.scientific confs 0] :: IO (Either HttpException (Response (RpcResponse [ZcashTx])))
case res of
Right txList -> do
let content = getResponseBody txList :: RpcResponse [ZcashTx]
case err content of
Nothing ->
return $
Right $ filter (not . zchange) $ fromMaybe [] $ result content
Just e -> return $ Left $ "Error reading transactions: " <> emessage e
Left ex -> return $ Left $ (T.pack . show) ex
2022-07-22 16:04:15 +00:00
-- | 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}).*"
2022-08-26 22:10:59 +00:00
let y =
mkRegex
2022-08-29 20:35:24 +00:00
".*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)
2022-08-26 22:10:59 +00:00
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
2022-07-22 16:04:15 +00:00
Left e -> do
putStrLn $ "Error scanning node transactions: " ++ T.unpack e
return ()
2022-07-22 16:04:15 +00:00
-- | Function to filter transactions
isRelevant :: Text.Regex.Regex -> ZcashTx -> Bool
isRelevant re t
2023-02-28 20:58:41 +00:00
| zconfirmations t < 100 && (matchTest re . T.unpack . zmemo) t = True
2022-07-22 16:04:15 +00:00
| otherwise = False
2023-03-14 15:17:31 +00:00
-- | New function to scan transactions with parser
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 -> mapM_ (zToZGoTx' config pipe) txs
Left e -> do
putStrLn $ "Error scanning node transactions: " ++ T.unpack e
2022-07-22 16:04:15 +00:00
-- | 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
2022-07-13 14:21:23 +00:00
where
2022-07-22 16:04:15 +00:00
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
2022-09-09 16:17:59 +00:00
mapM_ (recordPayment p (c_dbName config)) j
2022-07-22 16:04:15 +00:00
mapM_ (access p master (c_dbName config) . markOrderPaid) j
2022-09-09 16:17:59 +00:00
Left e -> print e
2022-07-22 19:01:08 +00:00
getOrderId :: Text.Regex.Regex -> ZcashTx -> (String, Double)
2022-07-22 16:04:15 +00:00
getOrderId re t = do
let reg = matchAllText re (T.unpack $ zmemo t)
if not (null reg)
2022-07-22 19:01:08 +00:00
then (fst $ head reg ! 1, zamount t)
else ("", 0)
2022-09-09 16:17:59 +00:00
recordPayment :: Pipe -> T.Text -> (String, Double) -> IO ()
recordPayment p dbName x = do
o <- access p master dbName $ findOrderById (fst x)
let xOrder = o >>= (cast' . Doc)
case xOrder of
Nothing -> error "Failed to retrieve order from database"
Just xO ->
when
(not (qpaid xO) &&
qexternalInvoice xO /= "" && qtotalZec xO == snd x) $ 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)
2023-02-28 17:19:08 +00:00
(qtotalZec xO)
"WC" -> do
let wOwner = fst $ head sResult ! 2
wooT <-
access p master dbName $ findWooToken (read wOwner)
let wT = wooT >>= (cast' . Doc)
case wT of
Nothing -> error "Failed to read WooCommerce token"
Just wt -> do
2022-12-13 20:01:51 +00:00
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)
2022-12-06 20:35:13 +00:00
(C.pack $ maybe "" show (q_id xO))
2022-12-06 22:35:04 +00:00
(C.pack . T.unpack $ w_token wt)
(C.pack . show $ qprice xO)
(C.pack . show $ qtotalZec xO)
else error
"Couldn't parse externalInvoice for WooCommerce"
_ -> putStrLn "Not an integration order"
else putStrLn "Not an integration order"
2022-05-03 13:59:29 +00:00
-- | RPC methods
-- | List addresses with viewing keys loaded
listAddresses :: BS.ByteString -> BS.ByteString -> IO [ZcashAddress]
listAddresses user pwd = do
2023-04-28 18:05:02 +00:00
response <-
try $ makeZcashCall user pwd "listaddresses" [] :: IO (Either HttpException (Response (RpcResponse [AddressGroup])))
case response of
Right addrList -> do
let rpcResp = getResponseBody addrList
let addys = fromMaybe [] $ result rpcResp :: [AddressGroup]
let addList = concatMap getAddresses addys
return $ filter (\a -> source a == ImportedWatchOnly) addList
2023-04-28 18:05:02 +00:00
Left ex -> fail $ show ex
-- | Helper function to extract addresses from AddressGroups
getAddresses :: AddressGroup -> [ZcashAddress]
getAddresses ag = agtransparent ag <> agsapling ag <> agunified ag
2022-05-03 13:59:29 +00:00
-- | Function to generate users from login txs
2022-07-12 21:08:27 +00:00
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
2022-05-03 13:59:29 +00:00
results <-
access
pipe
master
db
(rest =<<
find (select ["confirmations" =: ["$lt" =: (100 :: Integer)]] "txs"))
2022-05-17 17:47:27 +00:00
let parsed = map (cast' . Doc) results
2022-05-19 17:56:56 +00:00
mapM_
(access pipe master db . ZGoBackend.addUser nodeUser nodePwd pipe db addr)
parsed
2022-05-03 13:59:29 +00:00
2022-05-17 17:47:27 +00:00
-- | 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)
2023-05-02 19:14:07 +00:00
print pmt
2022-05-17 17:47:27 +00:00
let parsedUser = parseUserBson =<< user
let zaddy = maybe "" uaddress parsedUser
owner <- access pipe master db $ findOwner zaddy
let foundOwner = (cast' . Doc) =<< owner
case foundOwner of
Nothing -> error "Couldn't find owner to mark as paid"
Just fOwn -> do
if pdelta pmt > 90000000
then do
_ <-
access
pipe
master
db
(modify
(select ["_id" =: o_id fOwn] "owners")
[ "$set" =:
[ "paid" =: True
, "invoices" =: True
, "expiration" =:
calculateExpiration
fOwn
(pdelta pmt - 90000000)
(pblocktime pmt)
]
])
2023-04-28 18:05:02 +00:00
let proS =
ZGoProSession
Nothing
(oaddress fOwn)
(calculateExpiration
fOwn
(pdelta pmt - 90000000)
(pblocktime pmt))
False
access pipe master db $ upsertProSession proS
markPaymentDone pipe db pmt
else do
_ <-
access
pipe
master
db
(modify
(select ["_id" =: o_id fOwn] "owners")
[ "$set" =:
[ "paid" =: True
, "expiration" =:
calculateExpiration
fOwn
(pdelta pmt)
(pblocktime pmt)
]
])
markPaymentDone pipe db pmt
calculateExpiration :: Owner -> Integer -> Integer -> UTCTime
calculateExpiration o delta blocktime =
if opaid o
then addUTCTime
(secondsToNominalDiffTime (fromIntegral delta))
(oexpiration o)
else posixSecondsToUTCTime (fromIntegral $ delta + blocktime)
2022-05-17 17:47:27 +00:00
2022-05-17 20:06:38 +00:00
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 ()
2023-04-11 14:58:07 +00:00
expireProSessions :: Pipe -> T.Text -> IO ()
expireProSessions pipe db = do
now <- getCurrentTime
psessions <- access pipe master db $ findExpiringProSessions now
2023-05-02 15:35:53 +00:00
print $ length psessions
2023-04-11 14:58:07 +00:00
let pSessObj = cast' . Doc <$> psessions
mapM_ (sendExpiration pipe db) pSessObj
where
sendExpiration :: Pipe -> T.Text -> Maybe ZGoProSession -> IO ()
sendExpiration pipe db zps =
case zps of
Nothing -> return ()
Just z -> do
access pipe master db $ removePro (psaddress z)
access pipe master db $ closeProSession z
2022-05-03 13:59:29 +00:00
debug = flip trace