Merge branch 'dev'
This commit is contained in:
commit
d060032668
GPG Key ID:
65122AD495A7F5B2
32
CHANGELOG.md
32
CHANGELOG.md
|
|
@ -6,13 +6,43 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
|
|||
|
||||
## [Unreleased]
|
||||
|
||||
## [1.0.0] - 2022-07-27
|
||||
|
||||
### Added
|
||||
|
||||
- New functionality to read transactions for the given viewing keys
|
||||
- New functionality to mark orders as paid once payment is found on-chain
|
||||
- New `Config` type to house the configuration parameters
|
||||
- New field in `Owner` type to store toggle for payment confirmation
|
||||
- New field in `Owner` type to store viewing key
|
||||
|
||||
### Changed
|
||||
|
||||
- Added chronological sorting to list of orders
|
||||
- Added logic in `/api/owner` endpoint to validate viewing key before saving
|
||||
- Updated tests for `/api/owner` to account for invalid viewing keys
|
||||
- Added alphabetic sorting to list of items
|
||||
- Refactored code to use new `Config` type
|
||||
- Enhance `decodeHexText` to support Unicode
|
||||
- Enhance `encodeHexText` to support Unicode
|
||||
- Update tests for encode/decode of memos
|
||||
|
||||
### Fixed
|
||||
|
||||
- Fixed the PIN generation
|
||||
- Fixed calculation of order total to ensure 8 decimal places
|
||||
- Fixed test for looking for an order with incorrect ID
|
||||
- Fixed payment scan to focus only on new transactions
|
||||
|
||||
## [0.1.0.2] - 2022-05-25
|
||||
|
||||
### Added
|
||||
|
||||
- Changelog
|
||||
- `paid` field in ZGoOrder type
|
||||
- Test for `api/order/:id` endpoint with an invalid ID
|
||||
|
||||
## Fixed
|
||||
### Fixed
|
||||
|
||||
- Bug #1: crash when invalid ID was provided to `api/order/:id`
|
||||
|
||||
|
|
|
|||
51
app/Main.hs
51
app/Main.hs
|
|
@ -2,9 +2,8 @@
|
|||
|
||||
module Main where
|
||||
|
||||
import Config
|
||||
import Control.Concurrent (forkIO)
|
||||
import Data.Configurator
|
||||
import Data.SecureMem
|
||||
import Database.MongoDB
|
||||
import Network.Wai.Handler.Warp (defaultSettings, setPort)
|
||||
import Network.Wai.Handler.WarpTLS (runTLS, tlsSettings)
|
||||
|
|
@ -14,40 +13,32 @@ import ZGoBackend
|
|||
main :: IO ()
|
||||
main = do
|
||||
putStrLn "Reading config..."
|
||||
config <- load ["zgo.cfg"]
|
||||
dbHost <- require config "dbHost"
|
||||
dbName <- require config "dbName"
|
||||
dbUser <- require config "dbUser"
|
||||
dbPassword <- require config "dbPassword"
|
||||
nodeAddress <- require config "nodeAddress"
|
||||
nodeUser <- require config "nodeUser"
|
||||
nodePwd <- require config "nodePassword"
|
||||
passkey <- secureMemFromByteString <$> require config "passkey"
|
||||
port <- require config "port"
|
||||
useTls <- require config "tls"
|
||||
cert <- require config "certificate"
|
||||
key <- require config "key"
|
||||
loadedConfig <- loadZGoConfig "zgo.cfg"
|
||||
let myTlsSettings =
|
||||
if useTls
|
||||
then Just $ tlsSettings cert key
|
||||
if c_useTls loadedConfig
|
||||
then Just $
|
||||
tlsSettings (c_certificate loadedConfig) (c_key loadedConfig)
|
||||
else Nothing
|
||||
putStrLn "Starting Server..."
|
||||
pipe <- connect $ host dbHost
|
||||
j <- access pipe master dbName (auth dbUser dbPassword)
|
||||
pipe <- connect $ host (c_dbHost loadedConfig)
|
||||
j <-
|
||||
access
|
||||
pipe
|
||||
master
|
||||
(c_dbName loadedConfig)
|
||||
(auth (c_dbUser loadedConfig) (c_dbPassword loadedConfig))
|
||||
if j
|
||||
then putStrLn "Connected to MongoDB!"
|
||||
else fail "MongoDB connection failed!"
|
||||
_ <- forkIO (setInterval 60 (checkZcashPrices pipe dbName))
|
||||
_ <-
|
||||
forkIO (setInterval 75 (scanZcash nodeAddress pipe dbName nodeUser nodePwd))
|
||||
_ <- forkIO (setInterval 60 (checkPayments pipe dbName))
|
||||
_ <- forkIO (setInterval 60 (expireOwners pipe dbName))
|
||||
_ <-
|
||||
forkIO
|
||||
(setInterval 60 (updateLogins nodeUser nodePwd nodeAddress pipe dbName))
|
||||
let appRoutes = routes pipe dbName passkey nodeAddress nodeUser nodePwd
|
||||
_ <- forkIO (setInterval 60 (checkZcashPrices pipe (c_dbName loadedConfig)))
|
||||
_ <- forkIO (setInterval 75 (scanZcash loadedConfig pipe))
|
||||
_ <- forkIO (setInterval 90 (scanPayments loadedConfig pipe))
|
||||
_ <- forkIO (setInterval 60 (checkPayments pipe (c_dbName loadedConfig)))
|
||||
_ <- forkIO (setInterval 60 (expireOwners pipe (c_dbName loadedConfig)))
|
||||
_ <- forkIO (setInterval 60 (updateLogins pipe loadedConfig))
|
||||
let appRoutes = routes pipe loadedConfig
|
||||
case myTlsSettings of
|
||||
Nothing -> scotty port appRoutes
|
||||
Nothing -> scotty (c_port loadedConfig) appRoutes
|
||||
Just tls -> do
|
||||
apiCore <- scottyApp appRoutes
|
||||
runTLS tls (setPort port defaultSettings) apiCore
|
||||
runTLS tls (setPort (c_port loadedConfig) defaultSettings) apiCore
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
name: zgo-backend
|
||||
version: 0.1.0.2
|
||||
version: 1.0.0
|
||||
git: "https://gitlab.com/pitmutt/zgo-backend"
|
||||
license: BOSL
|
||||
author: "Rene Vergara"
|
||||
|
|
@ -48,6 +48,9 @@ library:
|
|||
- vector
|
||||
- wai-cors
|
||||
- warp-tls
|
||||
- hexstring
|
||||
- configurator
|
||||
- scientific
|
||||
|
||||
executables:
|
||||
zgo-backend-exe:
|
||||
|
|
|
|||
|
|
@ -0,0 +1,55 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Config where
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Configurator
|
||||
import Data.SecureMem
|
||||
import qualified Data.Text as T
|
||||
|
||||
data Config =
|
||||
Config
|
||||
{ c_dbHost :: String
|
||||
, c_dbName :: T.Text
|
||||
, c_dbUser :: T.Text
|
||||
, c_dbPassword :: T.Text
|
||||
, c_passkey :: SecureMem
|
||||
, c_nodeAddress :: T.Text
|
||||
, c_nodeUser :: BS.ByteString
|
||||
, c_nodePwd :: BS.ByteString
|
||||
, c_port :: Int
|
||||
, c_useTls :: Bool
|
||||
, c_certificate :: String
|
||||
, c_key :: String
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
loadZGoConfig :: Worth FilePath -> IO Config
|
||||
loadZGoConfig path = do
|
||||
config <- load [path]
|
||||
dbHost <- require config "dbHost"
|
||||
dbName <- require config "dbName"
|
||||
dbUser <- require config "dbUser"
|
||||
dbPassword <- require config "dbPassword"
|
||||
nodeAddress <- require config "nodeAddress"
|
||||
nodeUser <- require config "nodeUser"
|
||||
nodePwd <- require config "nodePassword"
|
||||
passkey <- secureMemFromByteString <$> require config "passkey"
|
||||
port <- require config "port"
|
||||
useTls <- require config "tls"
|
||||
cert <- require config "certificate"
|
||||
key <- require config "key"
|
||||
return $
|
||||
Config
|
||||
dbHost
|
||||
dbName
|
||||
dbUser
|
||||
dbPassword
|
||||
passkey
|
||||
nodeAddress
|
||||
nodeUser
|
||||
nodePwd
|
||||
port
|
||||
useTls
|
||||
cert
|
||||
key
|
||||
|
|
@ -84,7 +84,8 @@ instance Val Item where
|
|||
|
||||
-- Database actions
|
||||
findItems :: T.Text -> Action IO [Document]
|
||||
findItems a = rest =<< find (select ["owner" =: a] "items")
|
||||
findItems a =
|
||||
rest =<< find (select ["owner" =: a] "items") {sort = ["name" =: (1 :: Int)]}
|
||||
|
||||
upsertItem :: Item -> Action IO ()
|
||||
upsertItem i = do
|
||||
|
|
|
|||
15
src/Order.hs
15
src/Order.hs
|
|
@ -188,7 +188,7 @@ updateOrderTotals o =
|
|||
(qprice o)
|
||||
(newTotal o)
|
||||
(if qprice o /= 0
|
||||
then newTotal o / qprice o
|
||||
then roundZec (newTotal o / qprice o)
|
||||
else 0)
|
||||
(qlines o)
|
||||
(qpaid o)
|
||||
|
|
@ -205,7 +205,18 @@ findOrderById :: String -> Action IO (Maybe Document)
|
|||
findOrderById i = findOne (select ["_id" =: (read i :: B.ObjectId)] "orders")
|
||||
|
||||
findAllOrders :: T.Text -> Action IO [Document]
|
||||
findAllOrders a = rest =<< find (select ["address" =: a] "orders")
|
||||
findAllOrders a = rest =<< find (select ["address" =: a] "orders") {sort = ["timestamp" =: (negate 1 :: Int)]}
|
||||
|
||||
deleteOrder :: String -> Action IO ()
|
||||
deleteOrder i = deleteOne (select ["_id" =: (read i :: B.ObjectId)] "orders")
|
||||
|
||||
markOrderPaid :: (String, Double) -> Action IO ()
|
||||
markOrderPaid (i, a) = do
|
||||
let
|
||||
modify
|
||||
(select ["_id" =: (read i :: B.ObjectId), "totalZec" =: a] "orders")
|
||||
["$set" =: ["paid" =: True]]
|
||||
|
||||
-- | Helper function to round to 8 decimal places
|
||||
roundZec :: Double -> Double
|
||||
roundZec n = fromInteger (round $ n * (10 ^ 8)) / (10.0 ^^ 8)
|
||||
|
|
|
|||
24
src/Owner.hs
24
src/Owner.hs
|
|
@ -6,6 +6,7 @@ module Owner where
|
|||
|
||||
import Data.Aeson
|
||||
import qualified Data.Bson as B
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock
|
||||
import Data.Typeable
|
||||
|
|
@ -37,11 +38,13 @@ data Owner =
|
|||
, ozats :: Bool
|
||||
, oinvoices :: Bool
|
||||
, oexpiration :: UTCTime
|
||||
, opayconf :: Bool
|
||||
, oviewkey :: T.Text
|
||||
}
|
||||
deriving (Eq, Show, Generic, Typeable)
|
||||
|
||||
instance ToJSON Owner where
|
||||
toJSON (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv eTs) =
|
||||
toJSON (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv eTs pc vk) =
|
||||
case i of
|
||||
Just oid ->
|
||||
object
|
||||
|
|
@ -67,6 +70,8 @@ instance ToJSON Owner where
|
|||
, "zats" .= zats
|
||||
, "invoices" .= inv
|
||||
, "expiration" .= eTs
|
||||
, "payconf" .= pc
|
||||
, "viewkey" .= vk
|
||||
]
|
||||
Nothing ->
|
||||
object
|
||||
|
|
@ -92,6 +97,8 @@ instance ToJSON Owner where
|
|||
, "zats" .= zats
|
||||
, "invoices" .= inv
|
||||
, "expiration" .= eTs
|
||||
, "payconf" .= pc
|
||||
, "viewkey" .= vk
|
||||
]
|
||||
|
||||
instance FromJSON Owner where
|
||||
|
|
@ -119,6 +126,8 @@ instance FromJSON Owner where
|
|||
zats <- obj .: "zats"
|
||||
inv <- obj .: "invoices"
|
||||
ets <- obj .: "expiration"
|
||||
pc <- obj .:? "payconf"
|
||||
vk <- obj .:? "viewkey"
|
||||
pure $
|
||||
Owner
|
||||
(if not (null i)
|
||||
|
|
@ -145,6 +154,8 @@ instance FromJSON Owner where
|
|||
zats
|
||||
inv
|
||||
ets
|
||||
(fromMaybe False pc)
|
||||
(fromMaybe "" vk)
|
||||
|
||||
instance Val Owner where
|
||||
cast' (Doc d) = do
|
||||
|
|
@ -170,9 +181,12 @@ instance Val Owner where
|
|||
zats <- B.lookup "zats" d
|
||||
inv <- B.lookup "invoices" d
|
||||
ets <- B.lookup "expiration" d
|
||||
Just (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv ets)
|
||||
pc <- B.lookup "payconf" d
|
||||
vk <- B.lookup "viewKey" d
|
||||
Just
|
||||
(Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv ets pc vk)
|
||||
cast' _ = Nothing
|
||||
val (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv ets) =
|
||||
val (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv ets pc vk) =
|
||||
case i of
|
||||
Just oid ->
|
||||
Doc
|
||||
|
|
@ -198,6 +212,8 @@ instance Val Owner where
|
|||
, "zats" =: zats
|
||||
, "invoices" =: inv
|
||||
, "expiration" =: ets
|
||||
, "payconf" =: pc
|
||||
, "viewKey" =: vk
|
||||
]
|
||||
Nothing ->
|
||||
Doc
|
||||
|
|
@ -222,6 +238,8 @@ instance Val Owner where
|
|||
, "zats" =: zats
|
||||
, "invoices" =: inv
|
||||
, "expiration" =: ets
|
||||
, "payconf" =: pc
|
||||
, "viewKey" =: vk
|
||||
]
|
||||
|
||||
-- Database actions
|
||||
|
|
|
|||
|
|
@ -99,9 +99,9 @@ validateUser session =
|
|||
(select ["session" =: session] "users")
|
||||
["$set" =: ["validated" =: True]]
|
||||
|
||||
generatePin :: IO T.Text
|
||||
generatePin = do
|
||||
g <- newStdGen
|
||||
generatePin :: Int -> IO T.Text
|
||||
generatePin s = do
|
||||
let g = mkStdGen s
|
||||
pure $
|
||||
T.pack (padLeft (show . head $ randomRs (1 :: Integer, 10000000) g) '0' 7)
|
||||
|
||||
|
|
|
|||
|
|
@ -2,9 +2,11 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module ZGoBackend where
|
||||
|
||||
import Config
|
||||
import Control.Concurrent (forkIO, threadDelay)
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
|
|
@ -14,9 +16,13 @@ import qualified Data.Bson as B
|
|||
import qualified Data.ByteString as BS
|
||||
import Data.Char
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Data.HexString
|
||||
import Data.Maybe
|
||||
import qualified Data.Scientific as Scientific
|
||||
import Data.SecureMem
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import Data.Text.Encoding.Error (lenientDecode)
|
||||
import qualified Data.Text.Lazy as L
|
||||
import Data.Time.Clock
|
||||
import Data.Time.Clock.POSIX
|
||||
|
|
@ -63,9 +69,9 @@ instance ToJSON RpcCall where
|
|||
-- | A type to model the response of the Zcash RPC
|
||||
data RpcResponse r =
|
||||
MakeRpcResponse
|
||||
{ err :: Maybe T.Text
|
||||
{ err :: Maybe RpcError
|
||||
, respId :: T.Text
|
||||
, result :: r
|
||||
, result :: Maybe r
|
||||
}
|
||||
deriving (Show, Generic, ToJSON)
|
||||
|
||||
|
|
@ -74,6 +80,20 @@ instance (FromJSON r) => FromJSON (RpcResponse r) where
|
|||
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
|
||||
|
|
@ -118,7 +138,7 @@ instance FromJSON ZcashTx where
|
|||
aZ <- obj .: "amountZat"
|
||||
bh <- obj .: "blockheight"
|
||||
bt <- obj .: "blocktime"
|
||||
c <- obj .: "change"
|
||||
c <- obj .:? "change"
|
||||
conf <- obj .: "confirmations"
|
||||
m <- obj .: "memo"
|
||||
pure $
|
||||
|
|
@ -128,9 +148,9 @@ instance FromJSON ZcashTx where
|
|||
aZ
|
||||
bh
|
||||
bt
|
||||
c
|
||||
(fromMaybe False c)
|
||||
conf
|
||||
(T.pack (filter (/= '\NUL') $ decodeHexText m))
|
||||
(T.filter (/= '\NUL') $ decodeHexText m)
|
||||
|
||||
instance ToJSON ZcashTx where
|
||||
toJSON (ZcashTx t a aZ bh bt c conf m) =
|
||||
|
|
@ -156,23 +176,123 @@ instance Arbitrary ZcashTx where
|
|||
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 -> String
|
||||
decodeHexText hexText
|
||||
-- | chunk == "00" = decodeHexText (drop 2 hexText)
|
||||
| null chunk = ""
|
||||
| otherwise = chr (read ("0x" <> chunk)) : decodeHexText (drop 2 hexText)
|
||||
decodeHexText :: String -> T.Text
|
||||
decodeHexText h = E.decodeUtf8With lenientDecode $ BS.pack $ hexRead h
|
||||
where
|
||||
chunk = take 2 hexText
|
||||
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 :: String -> String
|
||||
encodeHexText t = mconcat (map padHex t)
|
||||
where
|
||||
padHex x =
|
||||
if ord x < 16
|
||||
then "0" ++ (showHex . ord) x ""
|
||||
else showHex (ord x) ""
|
||||
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
|
||||
|
|
@ -204,8 +324,8 @@ zToZGoTx (ZcashTx t a aZ bh bt c conf m) = do
|
|||
if not (null reg)
|
||||
then do
|
||||
let sess = T.pack (fst $ head reg ! 1)
|
||||
let addy = T.pack (fst $ head reg ! 2)
|
||||
ZGoTx Nothing addy sess conf bt a t m
|
||||
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
|
||||
|
|
@ -262,7 +382,7 @@ sendPin nodeUser nodePwd nodeAddress addr pin = do
|
|||
[ object
|
||||
[ "address" .= addr
|
||||
, "amount" .= (0.00000001 :: Double)
|
||||
, "memo" .= encodeHexText ("ZGo PIN: " ++ T.unpack pin)
|
||||
, "memo" .= encodeHexText ("ZGo PIN: " <> pin)
|
||||
]
|
||||
])
|
||||
]
|
||||
|
|
@ -285,7 +405,7 @@ addUser _ _ _ _ _ Nothing = return () --`debug` "addUser got Nothing"
|
|||
addUser nodeUser nodePwd p db node (Just tx) = do
|
||||
isNew <- liftIO $ isUserNew p db tx
|
||||
when isNew $ do
|
||||
let newPin = unsafePerformIO generatePin
|
||||
let newPin = unsafePerformIO (generatePin (fromIntegral $ blocktime tx))
|
||||
_ <- sendPin nodeUser nodePwd node (address tx) newPin
|
||||
insert_
|
||||
"users"
|
||||
|
|
@ -327,16 +447,13 @@ upsertZGoTx coll t = do
|
|||
upsert (select ["txid" =: txid t] coll) (encodeZGoTxBson t)
|
||||
|
||||
-- | Main API routes
|
||||
routes ::
|
||||
Pipe
|
||||
-> T.Text
|
||||
-> SecureMem
|
||||
-> T.Text
|
||||
-> BS.ByteString
|
||||
-> BS.ByteString
|
||||
-> ScottyM ()
|
||||
routes pipe db passkey nodeAddress nodeUser nodePwd = do
|
||||
let run = access pipe master db
|
||||
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 $
|
||||
|
|
@ -404,7 +521,13 @@ routes pipe db passkey nodeAddress nodeUser nodePwd = do
|
|||
--Get current blockheight from Zcash node
|
||||
get "/api/blockheight" $ do
|
||||
blockInfo <- makeZcashCall nodeUser nodePwd "getblock" ["-1"]
|
||||
Web.Scotty.json (result (getResponseBody blockInfo :: RpcResponse Block))
|
||||
let content = getResponseBody blockInfo :: RpcResponse Block
|
||||
if isNothing (err content)
|
||||
then do
|
||||
status ok200
|
||||
Web.Scotty.json $ fromMaybe (Block 0 0) (result content)
|
||||
else do
|
||||
status internalServerError500
|
||||
--Get the ZGo node's shielded address
|
||||
get "/api/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress])
|
||||
--Get owner by address
|
||||
|
|
@ -428,8 +551,30 @@ routes pipe db passkey nodeAddress nodeUser nodePwd = do
|
|||
post "/api/owner" $ do
|
||||
o <- jsonData
|
||||
let q = payload (o :: Payload Owner)
|
||||
_ <- liftIO $ run (upsertOwner q)
|
||||
status created201
|
||||
known <- liftIO $ listAddresses nodeUser nodePwd
|
||||
if not (opayconf q)
|
||||
then do
|
||||
_ <- liftIO $ run (upsertOwner q)
|
||||
status created201
|
||||
else do
|
||||
if oaddress q `elem` map addy known
|
||||
then do
|
||||
_ <- liftIO $ run (upsertOwner q)
|
||||
status created201
|
||||
else do
|
||||
vkInfo <-
|
||||
makeZcashCall
|
||||
nodeUser
|
||||
nodePwd
|
||||
"z_importviewingkey"
|
||||
[Data.Aeson.String (oviewkey q), "no"]
|
||||
let content = getResponseBody vkInfo :: RpcResponse Object
|
||||
if isNothing (err content)
|
||||
then do
|
||||
_ <- liftIO $ run (upsertOwner q)
|
||||
status created201
|
||||
else do
|
||||
status internalServerError500
|
||||
--Get items associated with the given address
|
||||
get "/api/items" $ do
|
||||
addr <- param "address"
|
||||
|
|
@ -575,33 +720,101 @@ checkZcashPrices p db = do
|
|||
q <- getZcashPrices
|
||||
mapM_ (access p master db) (updatePrices (getResponseBody q))
|
||||
|
||||
-- | Function to check the ZGo full node for new txs
|
||||
scanZcash :: T.Text -> Pipe -> T.Text -> BS.ByteString -> BS.ByteString -> IO ()
|
||||
scanZcash addr pipe db nodeUser nodePwd = do
|
||||
-- | Function to search for transactions for an address
|
||||
listTxs ::
|
||||
BS.ByteString
|
||||
-> BS.ByteString
|
||||
-> T.Text
|
||||
-> Integer
|
||||
-> IO (Either T.Text [ZcashTx])
|
||||
listTxs user pwd a confs = do
|
||||
res <-
|
||||
liftIO $
|
||||
makeZcashCall
|
||||
nodeUser
|
||||
nodePwd
|
||||
user
|
||||
pwd
|
||||
"z_listreceivedbyaddress"
|
||||
[Data.Aeson.String addr]
|
||||
let txs =
|
||||
filter (not . zchange) $
|
||||
result (getResponseBody res :: RpcResponse [ZcashTx])
|
||||
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 k = map zToZGoTx (filter (matchTest r . T.unpack . zmemo) txs)
|
||||
mapM_ (access pipe master db . upsertZGoTx "txs") k
|
||||
let j = map zToZGoTx (filter (matchTest p . T.unpack . zmemo) txs)
|
||||
mapM_ (access pipe master db . upsertPayment) j
|
||||
[Data.Aeson.String a, Data.Aeson.Number $ Scientific.scientific confs 0]
|
||||
let content = getResponseBody res :: RpcResponse [ZcashTx]
|
||||
case err content of
|
||||
Nothing ->
|
||||
return $ Right $ filter (not . zchange) $ fromMaybe [] $ result content
|
||||
Just e -> return $ Left $ "Error reading transactions: " <> emessage e
|
||||
|
||||
-- | Function to check the ZGo full node for new txs
|
||||
scanZcash :: Config -> Pipe -> IO ()
|
||||
scanZcash config pipe = do
|
||||
myTxs <-
|
||||
listTxs (c_nodeUser config) (c_nodePwd config) (c_nodeAddress config) 1
|
||||
case myTxs of
|
||||
Right txs -> do
|
||||
let r =
|
||||
mkRegex
|
||||
".*ZGO::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12})\\sReply-To:\\s(zs[a-z0-9]{76}).*"
|
||||
let p =
|
||||
mkRegex
|
||||
".*ZGOp::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12}).*"
|
||||
let k = map zToZGoTx (filter (isRelevant r) txs)
|
||||
mapM_ (access pipe master (c_dbName config) . upsertZGoTx "txs") k
|
||||
let j = map zToZGoTx (filter (isRelevant p) txs)
|
||||
mapM_ (access pipe master (c_dbName config) . upsertPayment) j
|
||||
Left e -> do
|
||||
putStrLn $ "Error scanning node transactions: " ++ T.unpack e
|
||||
return ()
|
||||
|
||||
-- | Function to filter transactions
|
||||
isRelevant :: Text.Regex.Regex -> ZcashTx -> Bool
|
||||
isRelevant re t
|
||||
| zconfirmations t < 10 && (matchTest re . T.unpack . zmemo) t = True
|
||||
| otherwise = False
|
||||
|
||||
-- | Function to scan loaded viewing keys for payments
|
||||
scanPayments :: Config -> Pipe -> IO ()
|
||||
scanPayments config pipe = do
|
||||
shops <- listAddresses (c_nodeUser config) (c_nodePwd config)
|
||||
mapM_ (findPaidOrders config pipe) shops
|
||||
where
|
||||
findPaidOrders :: Config -> Pipe -> ZcashAddress -> IO ()
|
||||
findPaidOrders c p z = do
|
||||
paidTxs <- listTxs (c_nodeUser c) (c_nodePwd c) (addy z) 5
|
||||
case paidTxs of
|
||||
Right txs -> do
|
||||
let r = mkRegex ".*ZGo Order::([0-9a-fA-F]{24}).*"
|
||||
let k = filter (isRelevant r) txs
|
||||
let j = map (getOrderId r) k
|
||||
mapM_ (access p master (c_dbName config) . markOrderPaid) j
|
||||
Left e -> putStrLn $ T.unpack e
|
||||
getOrderId :: Text.Regex.Regex -> ZcashTx -> (String, Double)
|
||||
getOrderId re t = do
|
||||
let reg = matchAllText re (T.unpack $ zmemo t)
|
||||
if not (null reg)
|
||||
then (fst $ head reg ! 1, zamount t)
|
||||
else ("", 0)
|
||||
|
||||
-- | RPC methods
|
||||
-- | List addresses with viewing keys loaded
|
||||
listAddresses :: BS.ByteString -> BS.ByteString -> IO [ZcashAddress]
|
||||
listAddresses user pwd = do
|
||||
response <- makeZcashCall user pwd "listaddresses" []
|
||||
let rpcResp = getResponseBody response
|
||||
case rpcResp of
|
||||
Nothing -> fail "Couldn't parse node response"
|
||||
Just res -> do
|
||||
let addys = fromMaybe [] $ result res :: [AddressGroup]
|
||||
let addList = concatMap getAddresses addys
|
||||
return $ filter (\a -> source a == ImportedWatchOnly) addList
|
||||
|
||||
-- | Helper function to extract addresses from AddressGroups
|
||||
getAddresses :: AddressGroup -> [ZcashAddress]
|
||||
getAddresses ag = agtransparent ag <> agsapling ag <> agunified ag
|
||||
|
||||
-- | Function to generate users from login txs
|
||||
updateLogins ::
|
||||
BS.ByteString -> BS.ByteString -> T.Text -> Pipe -> T.Text -> IO ()
|
||||
updateLogins nodeUser nodePwd addr pipe db = do
|
||||
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
|
||||
|
|
|
|||
|
|
@ -41,7 +41,9 @@ packages:
|
|||
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
|
||||
#
|
||||
# extra-deps: []
|
||||
|
||||
extra-deps:
|
||||
- git: https://github.com/reach-sh/haskell-hexstring.git
|
||||
commit: 085c16fb21b9f856a435a3faab980e7e0b319341
|
||||
# Override default flag values for local packages and extra-deps
|
||||
# flags: {}
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,18 @@
|
|||
# For more information, please see the documentation at:
|
||||
# https://docs.haskellstack.org/en/stable/lock_files
|
||||
|
||||
packages: []
|
||||
packages:
|
||||
- completed:
|
||||
name: hexstring
|
||||
version: 0.11.1
|
||||
git: https://github.com/reach-sh/haskell-hexstring.git
|
||||
pantry-tree:
|
||||
size: 687
|
||||
sha256: 9ecf67856f59dfb382b283eceb42e4fc1865935d1a7e59111556ed381c6a2ffd
|
||||
commit: 085c16fb21b9f856a435a3faab980e7e0b319341
|
||||
original:
|
||||
git: https://github.com/reach-sh/haskell-hexstring.git
|
||||
commit: 085c16fb21b9f856a435a3faab980e7e0b319341
|
||||
snapshots:
|
||||
- completed:
|
||||
size: 618683
|
||||
|
|
|
|||
66
test/Spec.hs
66
test/Spec.hs
|
|
@ -2,12 +2,12 @@
|
|||
|
||||
module Spec where
|
||||
|
||||
import Config
|
||||
import Control.Concurrent (forkIO, threadDelay)
|
||||
import Control.Exception (bracket)
|
||||
import Control.Monad.IO.Class
|
||||
import qualified Data.Aeson as A
|
||||
import qualified Data.ByteString as B
|
||||
import Data.Char (isAscii)
|
||||
import Data.Configurator
|
||||
import Data.Either
|
||||
import Data.Maybe
|
||||
|
|
@ -39,12 +39,7 @@ import ZGoTx
|
|||
main :: IO ()
|
||||
main = do
|
||||
putStrLn "Reading config..."
|
||||
config <- load ["zgo.cfg"]
|
||||
let dbName = "test"
|
||||
nodeAddress <- require config "nodeAddress"
|
||||
nodeUser <- require config "nodeUser"
|
||||
nodePwd <- require config "nodePassword"
|
||||
passkey <- secureMemFromByteString <$> require config "passkey"
|
||||
loadedConfig <- loadZGoConfig "zgotest.cfg"
|
||||
hspec $ do
|
||||
describe "Helper functions" $ do
|
||||
describe "decodeHexText" $ do
|
||||
|
|
@ -54,7 +49,7 @@ main = do
|
|||
"ZGO::5d3d4494-51c0-432d-8495-050419957aea\nReply-To:\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
|
||||
describe "hex strings" $ do
|
||||
prop "encoding and decoding are inverse" $ \x ->
|
||||
(decodeHexText . encodeHexText) (filter isAscii x) == filter isAscii x
|
||||
(decodeHexText . encodeHexText) x == x
|
||||
describe "zToZGoTx" $ do
|
||||
it "converts zcash tx to ZGo tx" $ do
|
||||
let t =
|
||||
|
|
@ -81,7 +76,7 @@ main = do
|
|||
it "should give a 7 digit" $ do
|
||||
length (T.unpack (unsafePerformIO generatePin)) `shouldBe` 7
|
||||
describe "API endpoints" $ do
|
||||
beforeAll_ (startAPI dbName passkey nodeAddress nodeUser nodePwd) $ do
|
||||
beforeAll_ (startAPI loadedConfig) $ do
|
||||
describe "Price endpoint" $ do
|
||||
it "returns a price for an existing currency" $ do
|
||||
req <- testGet "/api/price" [("currency", Just "usd")]
|
||||
|
|
@ -158,7 +153,7 @@ main = do
|
|||
it "get order with wrong id" $ do
|
||||
req <- testGet "/api/order/6273hrb" []
|
||||
res <- httpLBS req
|
||||
getResponseStatus res `shouldBe` unprocessableEntity422
|
||||
getResponseStatus res `shouldBe` noContent204
|
||||
it "get all orders for owner" $ do
|
||||
req <- testGet "/api/allorders" [("address", Just "Zaddy")]
|
||||
res <- httpJSON req
|
||||
|
|
@ -238,11 +233,38 @@ main = do
|
|||
access p master "test" $
|
||||
findOne (select ["_id" =: userId] "users")
|
||||
isNothing q `shouldBe` True
|
||||
describe "Orders" $ do
|
||||
it "marked as paid" $ \p -> do
|
||||
myTs <- liftIO getCurrentTime
|
||||
let myOrder =
|
||||
ZGoOrder
|
||||
(Just (read "627ab3ea2b05a76be3000001"))
|
||||
"Zaddy"
|
||||
"35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd"
|
||||
myTs
|
||||
False
|
||||
"usd"
|
||||
102.0
|
||||
0
|
||||
0
|
||||
[]
|
||||
False
|
||||
let ordTest = val myOrder
|
||||
case ordTest of
|
||||
Doc oT -> access p master "test" (insert_ "orders" oT)
|
||||
_ <-
|
||||
access p master "test" $ markOrderPaid "627ab3ea2b05a76be3000001"
|
||||
o <-
|
||||
access p master "test" $ findOrderById "627ab3ea2b05a76be3000001"
|
||||
let o1 = (cast' . Doc) =<< o
|
||||
case o1 of
|
||||
Nothing -> True `shouldBe` False
|
||||
Just o2 -> qpaid o2 `shouldBe` True
|
||||
describe "Zcash transactions" $ do
|
||||
it "logins are added to db" $ \p -> do
|
||||
_ <-
|
||||
access p master "test" (Database.MongoDB.delete (select [] "txs"))
|
||||
_ <- scanZcash nodeAddress p "test" nodeUser nodePwd
|
||||
_ <- scanZcash loadedConfig p
|
||||
threadDelay 1000000
|
||||
t <- access p master "test" $ findOne (select [] "txs")
|
||||
let s = parseZGoTxBson =<< t
|
||||
|
|
@ -255,7 +277,7 @@ main = do
|
|||
master
|
||||
"test"
|
||||
(Database.MongoDB.delete (select [] "payments"))
|
||||
_ <- scanZcash nodeAddress p "test" nodeUser nodePwd
|
||||
_ <- scanZcash loadedConfig p
|
||||
threadDelay 1000000
|
||||
t <- access p master "test" $ findOne (select [] "payments")
|
||||
let s = (cast' . Doc) =<< t
|
||||
|
|
@ -346,7 +368,7 @@ main = do
|
|||
"test"
|
||||
(Database.MongoDB.delete (select [] "users"))
|
||||
_ <- access p master "test" (insert_ "txs" (encodeZGoTxBson myTx))
|
||||
_ <- updateLogins nodeUser nodePwd nodeAddress p "test"
|
||||
_ <- updateLogins p loadedConfig
|
||||
threadDelay 1000000
|
||||
t <- access p master "test" $ findOne (select [] "users")
|
||||
case t of
|
||||
|
|
@ -407,7 +429,9 @@ testOwnerAdd o =
|
|||
req <-
|
||||
run $ testPostJson "/api/owner" (A.object ["payload" A..= A.toJSON o]) --`debug` show o
|
||||
res <- httpLBS req
|
||||
assert $ getResponseStatus res == created201
|
||||
if opayconf o
|
||||
then assert $ getResponseStatus res == internalServerError500
|
||||
else assert $ getResponseStatus res == created201
|
||||
|
||||
testOrderAdd :: ZGoOrder -> Property
|
||||
testOrderAdd o =
|
||||
|
|
@ -439,13 +463,12 @@ closeDbConnection = close
|
|||
handleDb :: (Pipe -> Expectation) -> IO ()
|
||||
handleDb = bracket openDbConnection closeDbConnection
|
||||
|
||||
startAPI ::
|
||||
T.Text -> SecureMem -> T.Text -> B.ByteString -> B.ByteString -> IO ()
|
||||
startAPI db passkey nodeAddress nodeUser nodePwd = do
|
||||
startAPI :: Config -> IO ()
|
||||
startAPI config = do
|
||||
putStrLn "Starting test server ..."
|
||||
pipe <- connect $ host "127.0.0.1"
|
||||
c <- access pipe master "zgo" (auth "zgo" "zcashrules")
|
||||
let appRoutes = routes pipe db passkey nodeAddress nodeUser nodePwd
|
||||
let appRoutes = routes pipe config
|
||||
_ <- forkIO (scotty 3000 appRoutes)
|
||||
let myUser =
|
||||
User
|
||||
|
|
@ -493,6 +516,8 @@ startAPI db passkey nodeAddress nodeUser nodePwd = do
|
|||
False
|
||||
False
|
||||
(UTCTime (fromGregorian 2022 4 16) (secondsToDiffTime 0))
|
||||
False
|
||||
""
|
||||
_ <- access pipe master "test" (Database.MongoDB.delete (select [] "owners"))
|
||||
let o = val myOwner
|
||||
case o of
|
||||
|
|
@ -577,8 +602,11 @@ instance Arbitrary Owner where
|
|||
paid <- arbitrary
|
||||
zats <- arbitrary
|
||||
inv <- arbitrary
|
||||
exp <- arbitrary
|
||||
payconf <- arbitrary
|
||||
--exp <- arbitrary
|
||||
Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv <$> arbitrary
|
||||
Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv exp payconf <$>
|
||||
arbitrary
|
||||
|
||||
instance Arbitrary Item where
|
||||
arbitrary = do
|
||||
|
|
|
|||
|
|
@ -26,6 +26,7 @@ source-repository head
|
|||
|
||||
library
|
||||
exposed-modules:
|
||||
Config
|
||||
Item
|
||||
Order
|
||||
Owner
|
||||
|
|
@ -44,6 +45,8 @@ library
|
|||
, base >=4.7 && <5
|
||||
, bson
|
||||
, bytestring
|
||||
, configurator
|
||||
, hexstring
|
||||
, http-conduit
|
||||
, http-types
|
||||
, mongoDB
|
||||
|
|
@ -51,6 +54,7 @@ library
|
|||
, random
|
||||
, regex-base
|
||||
, regex-compat
|
||||
, scientific
|
||||
, scotty
|
||||
, securemem
|
||||
, text
|
||||
|
|
|
|||
|
|
@ -0,0 +1,12 @@
|
|||
passkey = "superSecret"
|
||||
nodeAddress = "zs1xnpqd2tae9d95f8fhe4l0q7j44a5vf993m0pcnnvr56uqr4lgqlamesk5v4c5rhtvywc6lvlduy"
|
||||
dbHost = "127.0.0.1"
|
||||
dbName = "test"
|
||||
dbUser = "zgo"
|
||||
dbPassword = "zcashrules"
|
||||
nodeUser = "zecwallet"
|
||||
nodePassword = "rdsxlun6v4a"
|
||||
port = 3000
|
||||
tls = false
|
||||
certificate = "/path/to/cert.pem"
|
||||
key = "/path/to/key.pem"
|
||||
Loading…
Reference in New Issue