1850 lines
66 KiB
Haskell
1850 lines
66 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE DeriveAnyClass #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
|
|
module ZGoBackend where
|
|
|
|
import qualified BLAKE3 as BLK
|
|
import Config
|
|
import Control.Concurrent (forkIO, threadDelay)
|
|
import Control.Exception (try)
|
|
import Control.Monad
|
|
import Control.Monad.IO.Class
|
|
import Crypto.RNG (newCryptoRNGState, runCryptoRNGT)
|
|
import Crypto.RNG.Utils (randomString)
|
|
import Data.Aeson
|
|
import Data.Array
|
|
import qualified Data.Bson as B
|
|
import qualified Data.ByteArray as BA
|
|
import qualified Data.ByteString as BS
|
|
import qualified Data.ByteString.Base64 as B64
|
|
import qualified Data.ByteString.Char8 as C
|
|
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.Time.Format
|
|
import Data.Typeable
|
|
import qualified Data.UUID as U
|
|
import qualified Data.Vector as V
|
|
import Data.Vector.Internal.Check (doChecks)
|
|
import Data.Word
|
|
import Database.MongoDB hiding (Order)
|
|
import Debug.Trace
|
|
import GHC.Generics
|
|
import Item
|
|
import LangComponent
|
|
import Network.HTTP.Simple
|
|
import Network.HTTP.Types.Status
|
|
import Network.Wai (Application, Middleware, Request(..), pathInfo, responseLBS)
|
|
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.Megaparsec (runParser)
|
|
import Text.Regex
|
|
import Text.Regex.Base
|
|
import User
|
|
import Web.Scotty
|
|
import WooCommerce
|
|
import Xero
|
|
import ZGoTx
|
|
import ZcashHaskell.Sapling
|
|
import ZcashHaskell.Types (RawData(..))
|
|
import ZcashHaskell.Utils (decodeBech32)
|
|
|
|
-- 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
|
|
|
|
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 -> print $ "Failed to parse ZGo memo: " ++ show e
|
|
|
|
-- |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 <- 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)
|
|
|
|
-- | 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
|
|
newPin <- liftIO generatePin
|
|
_ <- sendPin nodeUser nodePwd node (address tx) (T.pack newPin)
|
|
let pinHash =
|
|
BLK.hash
|
|
[ BA.pack . BS.unpack . C.pack . T.unpack $
|
|
T.pack newPin <> session tx :: BA.Bytes
|
|
]
|
|
insert_
|
|
"users"
|
|
[ "address" =: address tx
|
|
, "session" =: session tx
|
|
, "blocktime" =: blocktime tx
|
|
, "pin" =:
|
|
(T.pack . show $ (pinHash :: BLK.Digest BLK.DEFAULT_DIGEST_LEN))
|
|
, "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 -> 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
|
|
_ -> return ()
|
|
|
|
authSettings :: AuthSettings
|
|
authSettings = "ZGo Backend" {authIsProtected = needsAuth}
|
|
|
|
needsAuth :: Network.Wai.Request -> IO Bool
|
|
needsAuth req =
|
|
return $
|
|
case pathInfo req of
|
|
"api":_ -> True
|
|
_ -> False
|
|
|
|
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
|
|
|
|
-- | 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)
|
|
authSettings
|
|
middleware $ zgoAuth pipe $ c_dbName config
|
|
--Get list of countries for UI
|
|
get "/api/countries" $ do
|
|
countries <- liftAndCatchIO $ 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 <- liftAndCatchIO $ 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"
|
|
session <- param "session"
|
|
user <- liftAndCatchIO $ run (findUser session)
|
|
xeroConfig <- liftAndCatchIO $ run findXero
|
|
case cast' . Doc =<< xeroConfig of
|
|
Nothing -> status noContent204
|
|
Just c -> do
|
|
case cast' . Doc =<< user of
|
|
Nothing -> status unauthorized401
|
|
Just u -> do
|
|
res <-
|
|
liftAndCatchIO $
|
|
requestXeroToken pipe (c_dbName config) c code $ uaddress u
|
|
if res
|
|
then status ok200
|
|
else status noContent204
|
|
post "/invdata" $ do
|
|
invData <- jsonData
|
|
xeroConfig <- liftAndCatchIO $ run findXero
|
|
let invReq = payload (invData :: Payload XeroInvoiceRequest)
|
|
case cast' . Doc =<< xeroConfig of
|
|
Nothing -> do
|
|
status ok200
|
|
Web.Scotty.json
|
|
(object
|
|
[ "reportType" .= (1 :: Integer)
|
|
, "order" .= (Nothing :: Maybe ZGoOrder)
|
|
, "shop" .= (Nothing :: Maybe String)
|
|
])
|
|
Just c -> do
|
|
o <- liftAndCatchIO $ run $ findOwnerById $ xr_owner invReq
|
|
case cast' . Doc =<< o of
|
|
Nothing -> do
|
|
status ok200
|
|
Web.Scotty.json
|
|
(object
|
|
[ "reportType" .= (2 :: Integer)
|
|
, "order" .= (Nothing :: Maybe ZGoOrder)
|
|
, "shop" .= (Nothing :: Maybe String)
|
|
])
|
|
Just o' -> do
|
|
existingOrder <-
|
|
liftAndCatchIO $
|
|
run $
|
|
findXeroOrder
|
|
(oaddress o')
|
|
(xr_invNo invReq)
|
|
(xr_shortCode invReq)
|
|
case cast' . Doc =<< existingOrder of
|
|
Nothing -> do
|
|
res <-
|
|
liftAndCatchIO $
|
|
requestXeroToken pipe (c_dbName config) c "none" $ oaddress o'
|
|
if res
|
|
then do
|
|
resInv <-
|
|
liftAndCatchIO $
|
|
getXeroInvoice pipe (c_dbName config) (xr_invNo invReq) $
|
|
oaddress o'
|
|
case resInv of
|
|
Nothing -> do
|
|
status ok200
|
|
Web.Scotty.json
|
|
(object
|
|
[ "reportType" .= (2 :: Integer)
|
|
, "order" .= (Nothing :: Maybe ZGoOrder)
|
|
, "shop" .= (Nothing :: Maybe String)
|
|
])
|
|
Just xI -> do
|
|
if xi_type xI == "ACCREC"
|
|
then if xi_status xI == "AUTHORISED"
|
|
then if xi_currency xI ==
|
|
T.toUpper (ocurrency o')
|
|
then if xi_total xI == xr_amount invReq
|
|
then do
|
|
now <- liftIO getCurrentTime
|
|
tk <- liftIO generateToken
|
|
pr <-
|
|
liftAndCatchIO $
|
|
run
|
|
(findPrice $
|
|
T.unpack . ocurrency $ o')
|
|
case parseZGoPrice =<< pr of
|
|
Nothing -> do
|
|
status ok200
|
|
Web.Scotty.json
|
|
(object
|
|
[ "reportType" .=
|
|
(7 :: Integer)
|
|
, "order" .=
|
|
(Nothing :: Maybe ZGoOrder)
|
|
, "shop" .=
|
|
(Nothing :: Maybe String)
|
|
])
|
|
Just cp -> do
|
|
let newOrder =
|
|
ZGoOrder
|
|
Nothing
|
|
(oaddress o')
|
|
("Xero-" <>
|
|
maybe
|
|
""
|
|
(T.pack . show)
|
|
(o_id o'))
|
|
now
|
|
True
|
|
(ocurrency o')
|
|
(price cp)
|
|
(xi_total xI)
|
|
(xi_total xI /
|
|
price cp)
|
|
[ LineItem
|
|
1
|
|
("Invoice from " <>
|
|
oname o' <>
|
|
" [" <>
|
|
xi_number xI <>
|
|
"]")
|
|
(xi_total xI)
|
|
]
|
|
False
|
|
(xi_number xI)
|
|
(xr_shortCode
|
|
invReq)
|
|
(T.pack tk)
|
|
_ <-
|
|
liftAndCatchIO $
|
|
run $
|
|
upsertOrder newOrder
|
|
finalOrder <-
|
|
liftAndCatchIO $
|
|
run $
|
|
findXeroOrder
|
|
(oaddress o')
|
|
(xi_number xI)
|
|
(xr_shortCode invReq)
|
|
case cast' . Doc =<<
|
|
finalOrder of
|
|
Nothing -> do
|
|
status
|
|
internalServerError500
|
|
text
|
|
"Unable to save order to DB"
|
|
Just fO -> do
|
|
status created201
|
|
Web.Scotty.json
|
|
(object
|
|
[ "reportType" .=
|
|
(0 :: Integer)
|
|
, "order" .=
|
|
toJSON
|
|
(fO :: ZGoOrder)
|
|
, "shop" .=
|
|
oname o'
|
|
])
|
|
else do
|
|
status ok200
|
|
Web.Scotty.json
|
|
(object
|
|
[ "reportType" .=
|
|
(8 :: Integer)
|
|
, "order" .=
|
|
(Nothing :: Maybe ZGoOrder)
|
|
, "shop" .=
|
|
(Nothing :: Maybe String)
|
|
])
|
|
else do
|
|
status ok200
|
|
Web.Scotty.json
|
|
(object
|
|
[ "reportType" .= (7 :: Integer)
|
|
, "order" .=
|
|
(Nothing :: Maybe ZGoOrder)
|
|
, "shop" .=
|
|
(Nothing :: Maybe String)
|
|
])
|
|
else do
|
|
status ok200
|
|
Web.Scotty.json
|
|
(object
|
|
[ "reportType" .= (6 :: Integer)
|
|
, "order" .= (Nothing :: Maybe ZGoOrder)
|
|
, "shop" .= (Nothing :: Maybe String)
|
|
])
|
|
else do
|
|
status ok200
|
|
Web.Scotty.json
|
|
(object
|
|
[ "reportType" .= (5 :: Integer)
|
|
, "order" .= (Nothing :: Maybe ZGoOrder)
|
|
, "shop" .= (Nothing :: Maybe String)
|
|
])
|
|
else do
|
|
status ok200
|
|
Web.Scotty.json
|
|
(object
|
|
[ "reportType" .= (1 :: Integer)
|
|
, "order" .= (Nothing :: Maybe ZGoOrder)
|
|
, "shop" .= (Nothing :: Maybe String)
|
|
])
|
|
Just eO -> do
|
|
status created201
|
|
Web.Scotty.json
|
|
(object
|
|
[ "reportType" .= (0 :: Integer)
|
|
, "order" .= toJSON (eO :: ZGoOrder)
|
|
, "shop" .= oname o'
|
|
])
|
|
-- Get the xeroaccount code
|
|
get "/api/xeroaccount" $ do
|
|
session <- param "session"
|
|
user <- liftAndCatchIO $ run (findUser session)
|
|
case cast' . Doc =<< user of
|
|
Nothing -> status unauthorized401
|
|
Just u -> do
|
|
res <- liftAndCatchIO $ run (findToken $ uaddress u)
|
|
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
|
|
session <- param "session"
|
|
c <- param "code"
|
|
user <- liftAndCatchIO $ run (findUser session)
|
|
case cast' . Doc =<< user of
|
|
Nothing -> status unauthorized401
|
|
Just u -> do
|
|
let oAdd = uaddress u
|
|
liftAndCatchIO $ run (addAccCode oAdd c)
|
|
status accepted202
|
|
-- Get the WooCommerce token
|
|
get "/api/wootoken" $ do
|
|
session <- param "session"
|
|
user <- liftAndCatchIO $ run (findUser session)
|
|
case cast' . Doc =<< user of
|
|
Nothing -> status unauthorized401
|
|
Just u -> do
|
|
owner <- liftAndCatchIO $ run (findOwner $ uaddress u)
|
|
case cast' . Doc =<< owner of
|
|
Nothing -> status internalServerError500
|
|
Just o -> do
|
|
res <- liftAndCatchIO $ run (findWooToken $ o_id o)
|
|
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"
|
|
session <- param "session"
|
|
user <- liftAndCatchIO $ run (findUser session)
|
|
case cast' . Doc =<< user of
|
|
Nothing -> status unauthorized401
|
|
Just u -> do
|
|
res <- liftAndCatchIO $ run (findOwnerById oid)
|
|
case cast' . Doc =<< res of
|
|
Nothing -> status badRequest400
|
|
Just o -> do
|
|
if oaddress o == uaddress u
|
|
then do
|
|
tk <- liftIO generateToken
|
|
liftAndCatchIO $ run (generateWooToken o tk)
|
|
status accepted202
|
|
else status forbidden403
|
|
-- Authenticate the WooCommerce plugin
|
|
get "/auth" $ do
|
|
oid <- param "ownerid"
|
|
t <- param "token"
|
|
siteurl <- param "siteurl"
|
|
res <- liftAndCatchIO $ run (findWooToken $ Just (read oid))
|
|
let c1 = cast' . Doc =<< res
|
|
case c1 of
|
|
Nothing -> do
|
|
status accepted202
|
|
Web.Scotty.json
|
|
(object
|
|
["authorized" .= False, "message" .= ("Owner not found" :: String)])
|
|
Just c ->
|
|
if blk3Hash t == blk3Hash (T.unpack $ 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))
|
|
])
|
|
else do
|
|
status accepted202
|
|
Web.Scotty.json
|
|
(object
|
|
[ "authorized" .= False
|
|
, "message" .= ("Token mismatch" :: String)
|
|
])
|
|
where blk3Hash :: String -> String
|
|
blk3Hash s =
|
|
show
|
|
(BLK.hash [BA.pack . BS.unpack . C.pack $ s :: BA.Bytes] :: BLK.Digest BLK.DEFAULT_DIGEST_LEN)
|
|
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"
|
|
orderKey <- param "orderkey"
|
|
res <- liftAndCatchIO $ run (findWooToken $ Just (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
|
|
tk <- liftIO generateToken
|
|
let newOrder =
|
|
ZGoOrder
|
|
Nothing
|
|
(oaddress o)
|
|
(case o_id o of
|
|
Just o' -> "WC-" <> (T.pack . show $ o')
|
|
Nothing -> "")
|
|
(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
|
|
(T.concat
|
|
[T.pack sUrl, "-", ordId, "-", orderKey])
|
|
""
|
|
(T.pack tk)
|
|
newId <- liftAndCatchIO $ run (insertWooOrder newOrder)
|
|
status ok200
|
|
Web.Scotty.json
|
|
(object ["order" .= show newId, "token" .= tk])
|
|
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)])
|
|
get "/checkuser" $ do
|
|
sess <- param "session"
|
|
user <- liftAndCatchIO $ run (findUser sess)
|
|
case parseUserBson =<< user of
|
|
Nothing -> status noContent204
|
|
Just u -> do
|
|
status ok200
|
|
Web.Scotty.json (object ["validated" .= uvalidated u])
|
|
--Get user associated with session
|
|
get "/api/user" $ do
|
|
sess <- param "session"
|
|
user <- liftAndCatchIO $ run (findUser sess)
|
|
case user of
|
|
Nothing -> status noContent204
|
|
Just u -> do
|
|
status ok200
|
|
Web.Scotty.json
|
|
(object
|
|
[ "message" .= ("User found" :: String)
|
|
, "user" .= toJSON (parseUserBson u)
|
|
])
|
|
--Validate user, updating record
|
|
post "/validateuser" $ do
|
|
providedPin <- param "pin"
|
|
sess <- param "session"
|
|
let pinHash =
|
|
BLK.hash
|
|
[ BA.pack . BS.unpack . C.pack . T.unpack $ providedPin <> sess :: BA.Bytes
|
|
]
|
|
user <- liftAndCatchIO $ 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 . show $
|
|
(pinHash :: BLK.Digest BLK.DEFAULT_DIGEST_LEN))
|
|
if ans
|
|
then do
|
|
liftAndCatchIO $ 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"
|
|
session <- param "session"
|
|
let r = mkRegex "^[a-f0-9]{24}$"
|
|
if matchTest r userId
|
|
then do
|
|
u <- liftAndCatchIO $ run (findUserById userId)
|
|
case cast' . Doc =<< u of
|
|
Nothing -> status badRequest400
|
|
Just u' ->
|
|
if session == usession u'
|
|
then do
|
|
liftAndCatchIO $ run (deleteUser userId)
|
|
status ok200
|
|
else status forbidden403
|
|
else status badRequest400
|
|
--Get current blockheight from Zcash node
|
|
get "/blockheight" $ do
|
|
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
|
|
--Get the ZGo node's shielded address
|
|
get "/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress])
|
|
--Get owner by address
|
|
get "/api/owner" $ do
|
|
session <- param "session"
|
|
user <- liftAndCatchIO $ run (findUser session)
|
|
case parseUserBson =<< user of
|
|
Nothing -> status noContent204
|
|
Just u -> do
|
|
owner <- liftAndCatchIO $ run (findOwner $ uaddress u)
|
|
case cast' . Doc =<< owner of
|
|
Nothing -> status noContent204
|
|
Just o -> do
|
|
status ok200
|
|
Web.Scotty.json
|
|
(object
|
|
[ "message" .= ("Owner found!" :: String)
|
|
, "owner" .= getOwnerSettings o
|
|
])
|
|
get "/ownerid" $ do
|
|
id <- param "id"
|
|
owner <- liftAndCatchIO $ 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" .= getOwnerSettings q
|
|
])
|
|
--Upsert owner to DB
|
|
post "/api/owner" $ do
|
|
s <- param "session"
|
|
u <- liftAndCatchIO $ run (findUser s)
|
|
o <- jsonData
|
|
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
|
|
post "/api/ownersettings" $ do
|
|
s <- param "session"
|
|
u <- liftAndCatchIO $ run (findUser s)
|
|
o <- jsonData
|
|
now <- liftIO getCurrentTime
|
|
let q = payload (o :: Payload OwnerSettings)
|
|
case parseUserBson =<< u of
|
|
Nothing -> status internalServerError500
|
|
Just u' -> do
|
|
if os_address q == uaddress u'
|
|
then do
|
|
liftAndCatchIO $ run $ updateOwnerSettings q
|
|
status accepted202
|
|
else status noContent204
|
|
post "/api/ownervk" $ do
|
|
s <- param "session"
|
|
u <- liftAndCatchIO $ run (findUser s)
|
|
o <- jsonData
|
|
let q = payload (o :: Payload String)
|
|
let qRaw = decodeBech32 $ C.pack q
|
|
if hrp qRaw == "fail"
|
|
then status badRequest400
|
|
else do
|
|
let qBytes = bytes qRaw
|
|
case cast' . Doc =<< u of
|
|
Nothing -> status unauthorized401
|
|
Just u' -> do
|
|
if isValidSaplingViewingKey qBytes
|
|
then if matchSaplingAddress
|
|
qBytes
|
|
(bytes . decodeBech32 . C.pack . T.unpack $ uaddress u')
|
|
then do
|
|
owner <- liftAndCatchIO $ run (findOwner $ uaddress u')
|
|
case cast' . Doc =<< owner of
|
|
Nothing -> status badRequest400
|
|
Just o' -> do
|
|
unless (oviewkey o' /= "") $ do
|
|
vkInfo <-
|
|
liftAndCatchIO $
|
|
makeZcashCall
|
|
nodeUser
|
|
nodePwd
|
|
"z_importviewingkey"
|
|
[ Data.Aeson.String (T.strip . T.pack $ q)
|
|
, "no"
|
|
]
|
|
let content =
|
|
getResponseBody vkInfo :: RpcResponse Object
|
|
if isNothing (err content)
|
|
then do
|
|
_ <-
|
|
liftAndCatchIO $ run (upsertViewingKey o' q)
|
|
status created201
|
|
else do
|
|
text $ L.pack . show $ err content
|
|
status badRequest400
|
|
else status forbidden403
|
|
else status badRequest400
|
|
--Get items associated with the given address
|
|
get "/api/items" $ do
|
|
session <- param "session"
|
|
user <- liftAndCatchIO $ run (findUser session)
|
|
case cast' . Doc =<< user of
|
|
Nothing -> status forbidden403
|
|
Just u -> do
|
|
items <- liftAndCatchIO $ run (findItems $ uaddress u)
|
|
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
|
|
session <- param "session"
|
|
user <- liftAndCatchIO $ run (findUser session)
|
|
case cast' . Doc =<< user of
|
|
Nothing -> status forbidden403
|
|
Just u -> do
|
|
let q = payload (i :: Payload Item)
|
|
if uaddress u == iowner q
|
|
then do
|
|
_ <- liftAndCatchIO $ run (upsertItem q)
|
|
status created201
|
|
else status forbidden403
|
|
--Delete item
|
|
Web.Scotty.delete "/api/item/:id" $ do
|
|
session <- param "session"
|
|
oId <- param "id"
|
|
u' <- liftAndCatchIO $ checkUser run session
|
|
case u' of
|
|
Nothing -> status forbidden403
|
|
Just u -> do
|
|
i <- liftAndCatchIO $ run (findItemById oId)
|
|
case cast' . Doc =<< i of
|
|
Nothing -> status badRequest400
|
|
Just i' -> do
|
|
if iowner i' == uaddress u
|
|
then do
|
|
liftAndCatchIO $ run (deleteItem oId)
|
|
status ok200
|
|
else status forbidden403
|
|
--Get price for Zcash
|
|
get "/price" $ do
|
|
curr <- param "currency"
|
|
pr <- liftAndCatchIO $ 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
|
|
session <- param "session"
|
|
user <- liftAndCatchIO $ run (findUser session)
|
|
case cast' . Doc =<< user of
|
|
Nothing -> status unauthorized401
|
|
Just u -> do
|
|
myOrders <- liftAndCatchIO $ run (findAllOrders $ uaddress u)
|
|
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 "/order/:id" $ do
|
|
oId <- param "id"
|
|
token <- param "token"
|
|
let r = mkRegex "^[a-f0-9]{24}$"
|
|
if matchTest r oId
|
|
then do
|
|
myOrder <- liftAndCatchIO $ run (findOrderById oId)
|
|
case cast' . Doc =<< myOrder of
|
|
Nothing -> status noContent204
|
|
Just pOrder -> do
|
|
if qtoken pOrder == token
|
|
then do
|
|
shop <- liftAndCatchIO $ run (findOwner $ qaddress pOrder)
|
|
case cast' . Doc =<< shop of
|
|
Nothing -> status badRequest400
|
|
Just s -> do
|
|
status ok200
|
|
Web.Scotty.json
|
|
(object
|
|
[ "message" .= ("Order found!" :: String)
|
|
, "order" .= toJSON (pOrder :: ZGoOrder)
|
|
, "shop" .= (oname s :: T.Text)
|
|
])
|
|
else status forbidden403
|
|
else status badRequest400
|
|
--Get order by session
|
|
get "/api/order" $ do
|
|
sess <- param "session"
|
|
myOrder <- liftAndCatchIO $ 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 <-
|
|
liftAndCatchIO $
|
|
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)
|
|
session <- param "session"
|
|
user <- liftAndCatchIO $ run (findUser session)
|
|
case cast' . Doc =<< user of
|
|
Nothing -> status unauthorized401
|
|
Just u -> do
|
|
if uaddress u == qaddress q
|
|
then do
|
|
if qtoken q == ""
|
|
then do
|
|
t <- liftIO generateToken
|
|
_ <-
|
|
liftAndCatchIO $
|
|
run (upsertOrder $ setOrderToken (T.pack t) q)
|
|
status created201
|
|
else do
|
|
_ <- liftAndCatchIO $ run (upsertOrder q)
|
|
status created201
|
|
else status forbidden403
|
|
--Delete order
|
|
Web.Scotty.delete "/api/order/:id" $ do
|
|
oId <- param "id"
|
|
session <- param "session"
|
|
o <- liftAndCatchIO $ run (findOrderById oId)
|
|
case cast' . Doc =<< o of
|
|
Nothing -> status badRequest400
|
|
Just order -> do
|
|
if qsession order == session
|
|
then do
|
|
liftAndCatchIO $ run (deleteOrder oId)
|
|
status ok200
|
|
else status forbidden403
|
|
-- Get language for component
|
|
get "/getmainlang" $ do
|
|
lang <- param "lang"
|
|
txtPack' <- liftAndCatchIO $ run (findLangComponent lang "main")
|
|
case cast' . Doc =<< txtPack' of
|
|
Nothing -> status noContent204
|
|
Just textPack -> do
|
|
status ok200
|
|
Web.Scotty.json $ toJSON (textPack :: LangComponent)
|
|
get "/getscanlang" $ do
|
|
lang <- param "lang"
|
|
txtPack' <- liftAndCatchIO $ run (findLangComponent lang "scan")
|
|
case cast' . Doc =<< txtPack' of
|
|
Nothing -> status noContent204
|
|
Just textPack -> do
|
|
status ok200
|
|
Web.Scotty.json $ toJSON (textPack :: LangComponent)
|
|
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)
|
|
get "/getinvoicelang" $ do
|
|
lang <- param "lang"
|
|
txtPack' <- liftAndCatchIO $ run (findLangComponent lang "invoice")
|
|
case cast' . Doc =<< txtPack' of
|
|
Nothing -> status noContent204
|
|
Just textPack -> do
|
|
status ok200
|
|
Web.Scotty.json $ toJSON (textPack :: LangComponent)
|
|
get "/getpmtservicelang" $ do
|
|
lang <- param "lang"
|
|
txtPack' <- liftAndCatchIO $ run (findLangComponent lang "pmtservice")
|
|
case cast' . Doc =<< txtPack' of
|
|
Nothing -> status noContent204
|
|
Just textPack -> do
|
|
status ok200
|
|
Web.Scotty.json $ toJSON (textPack :: LangComponent)
|
|
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)
|
|
{-post "/api/setlang" $ do-}
|
|
{-langComp <- jsonData-}
|
|
{-_ <--}
|
|
{-liftAndCatchIO $-}
|
|
{-mapM (run . loadLangComponent) (langComp :: [LangComponent])-}
|
|
{-status created201-}
|
|
|
|
-- | 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 <- try getZcashPrices
|
|
case q of
|
|
Left e -> print (e :: HttpException)
|
|
Right q1 -> mapM_ (access p master db) (updatePrices (getResponseBody q1))
|
|
|
|
-- | 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 <-
|
|
try $
|
|
makeZcashCall
|
|
user
|
|
pwd
|
|
"z_listreceivedbyaddress"
|
|
[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
|
|
|
|
-- | Function to filter transactions
|
|
isRelevant :: Integer -> Text.Regex.Regex -> ZcashTx -> Bool
|
|
isRelevant conf re t
|
|
| zconfirmations t < conf && (matchTest re . T.unpack . zmemo) t = True
|
|
| otherwise = False
|
|
|
|
-- | 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
|
|
|
|
-- | Function to scan loaded viewing keys for payments
|
|
scanPayments :: Config -> Pipe -> IO ()
|
|
scanPayments config pipe = do
|
|
shopRecords <- access pipe master (c_dbName config) findActiveOwners
|
|
case shopRecords of
|
|
[] -> return ()
|
|
_ -> do
|
|
let shops = cast' . Doc <$> shopRecords :: [Maybe Owner]
|
|
let validShopAddresses = map (maybe "" oaddress) $ filter isJust shops
|
|
mapM_ (findPaidOrders config pipe) validShopAddresses
|
|
where findPaidOrders :: Config -> Pipe -> T.Text -> IO ()
|
|
findPaidOrders c p z = do
|
|
print z
|
|
paidTxs <- listTxs (c_nodeUser c) (c_nodePwd c) z 5
|
|
case paidTxs of
|
|
Right txs -> do
|
|
let r = mkRegex ".*ZGo Order::([0-9a-fA-F]{24}).*"
|
|
let k = filter (isRelevant (c_confirmations c) r) txs
|
|
print k
|
|
let j = map (getOrderId r) k
|
|
mapM_ (recordPayment p (c_dbName config) z) j
|
|
Left e -> print 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)
|
|
recordPayment ::
|
|
Pipe -> T.Text -> T.Text -> (String, Double) -> IO ()
|
|
recordPayment p dbName z x = do
|
|
print x
|
|
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) && qtotalZec xO == snd x && z == qaddress xO) $ do
|
|
let sReg = mkRegex "(.*)-([a-fA-f0-9]{24})"
|
|
let sResult = matchAllText sReg (T.unpack $ qsession xO)
|
|
if not (null sResult)
|
|
then case fst $ head sResult ! 1 of
|
|
"Xero" -> do
|
|
xeroConfig <- access p master dbName findXero
|
|
let xC = xeroConfig >>= (cast' . Doc)
|
|
case xC of
|
|
Nothing -> error "Failed to read Xero config"
|
|
Just xConf -> do
|
|
requestXeroToken
|
|
p
|
|
dbName
|
|
xConf
|
|
""
|
|
(qaddress xO)
|
|
payXeroInvoice
|
|
p
|
|
dbName
|
|
(qexternalInvoice xO)
|
|
(qaddress xO)
|
|
(qtotal xO)
|
|
(qtotalZec xO)
|
|
liftIO $
|
|
access p master dbName $ markOrderPaid x
|
|
"WC" -> do
|
|
let wOwner = fst $ head sResult ! 2
|
|
wooT <-
|
|
access p master dbName $
|
|
findWooToken $ Just (read wOwner)
|
|
let wT = wooT >>= (cast' . Doc)
|
|
case wT of
|
|
Nothing ->
|
|
error "Failed to read WooCommerce token"
|
|
Just wt -> do
|
|
let iReg = mkRegex "(.*)-(.*)-.*"
|
|
let iResult =
|
|
matchAllText
|
|
iReg
|
|
(T.unpack $ qexternalInvoice xO)
|
|
if not (null iResult)
|
|
then do
|
|
let wUrl =
|
|
E.decodeUtf8With lenientDecode .
|
|
B64.decodeLenient . C.pack $
|
|
fst $ head iResult ! 1
|
|
let iNum = fst $ head iResult ! 2
|
|
payWooOrder
|
|
(T.unpack wUrl)
|
|
(C.pack iNum)
|
|
(C.pack $ maybe "" show (q_id xO))
|
|
(C.pack . T.unpack $ w_token wt)
|
|
(C.pack . show $ qprice xO)
|
|
(C.pack . show $ qtotalZec xO)
|
|
liftIO $
|
|
access p master dbName $
|
|
markOrderPaid x
|
|
else error
|
|
"Couldn't parse externalInvoice for WooCommerce"
|
|
_ -> putStrLn "Not an integration order"
|
|
else liftIO $ access p master dbName $ markOrderPaid x
|
|
|
|
-- | RPC methods
|
|
-- | List addresses with viewing keys loaded
|
|
listAddresses :: BS.ByteString -> BS.ByteString -> IO [ZcashAddress]
|
|
listAddresses user pwd = do
|
|
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
|
|
Left ex -> fail $ show ex
|
|
|
|
-- | 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)
|
|
print pmt
|
|
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)
|
|
]
|
|
])
|
|
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)
|
|
|
|
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 ()
|
|
|
|
expireProSessions :: Pipe -> T.Text -> IO ()
|
|
expireProSessions pipe db = do
|
|
now <- getCurrentTime
|
|
psessions <- access pipe master db $ findExpiringProSessions now
|
|
print $ length psessions
|
|
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
|
|
|
|
checkUser ::
|
|
(Action IO (Maybe Document) -> IO (Maybe Document))
|
|
-> T.Text
|
|
-> IO (Maybe User)
|
|
checkUser run s = do
|
|
user <- run (findUser s)
|
|
return $ cast' . Doc =<< user
|
|
|
|
generateToken :: IO String
|
|
generateToken = do
|
|
rngState <- newCryptoRNGState
|
|
runCryptoRNGT rngState $ randomString 24 "abcdef0123456789"
|
|
|
|
debug = flip trace
|