Vergara_Tech/zgo-backend
Vergara_Tech/zgo-backend
2
1
Fork 0
Code Issues Pull requests Projects Releases 4 Packages Wiki Activity

Refactor Payment type

Browse source
This commit is contained in:
Rene Vergara 2022-05-17 12:47:27 -05:00
parent 37912d35b1
commit 5a0bf9aee4
Signed by: pitmutt
GPG key ID: 65122AD495A7F5B2
8 changed files with 300 additions and 46 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
app/Main.hs
View file

@ -26,7 +26,8 @@ main = do
putStrLn "Starting Server..."
pipe <- connect $ host "127.0.0.1"
j <- access pipe master "zgo" (auth dbUser dbPassword)
{-_ <- forkIO (setInterval 60 (checkZcashPrices pipe))-}
_ <- forkIO (setInterval 60 (checkZcashPrices pipe "zgo"))
_ <- forkIO (setInterval 75 (scanZcash nodeAddress pipe "zgo"))
if j
then putStrLn "Connected to MongoDB!"
else fail "MongoDB connection failed!"

1
package.yaml
View file

@ -45,6 +45,7 @@ library:
- array
- random
- vector
- wai-cors
executables:
zgo-backend-exe:

15
src/Owner.hs
View file

@ -7,6 +7,7 @@ module Owner where
import Data.Aeson
import qualified Data.Bson as B
import qualified Data.Text as T
import Data.Time.Clock
import Data.Typeable
import Database.MongoDB
import GHC.Generics
@ -35,11 +36,12 @@ data Owner =
, opaid :: Bool
, ozats :: Bool
, oinvoices :: Bool
, oexpiration :: UTCTime
}
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) =
toJSON (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv eTs) =
case i of
Just oid ->
object
@ -64,6 +66,7 @@ instance ToJSON Owner where
, "paid" .= paid
, "zats" .= zats
, "invoices" .= inv
, "expiration" .= eTs
]
Nothing ->
object
@ -88,6 +91,7 @@ instance ToJSON Owner where
, "paid" .= paid
, "zats" .= zats
, "invoices" .= inv
, "expiration" .= eTs
]
instance FromJSON Owner where
@ -114,6 +118,7 @@ instance FromJSON Owner where
paid <- obj .: "paid"
zats <- obj .: "zats"
inv <- obj .: "invoices"
ets <- obj .: "expiration"
pure $
Owner
(if not (null i)
@ -139,6 +144,7 @@ instance FromJSON Owner where
paid
zats
inv
ets
instance Val Owner where
cast' (Doc d) = do
@ -163,9 +169,10 @@ instance Val Owner where
paid <- B.lookup "paid" d
zats <- B.lookup "zats" d
inv <- B.lookup "invoices" 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 <- 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)
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) =
val (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv ets) =
case i of
Just oid ->
Doc
@ -190,6 +197,7 @@ instance Val Owner where
, "paid" =: paid
, "zats" =: zats
, "invoices" =: inv
, "expiration" =: ets
]
Nothing ->
Doc
@ -213,6 +221,7 @@ instance Val Owner where
, "paid" =: paid
, "zats" =: zats
, "invoices" =: inv
, "expiration" =: ets
]
-- Database actions

95
src/Payment.hs Normal file
View file

@ -0,0 +1,95 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
module Payment where
import Data.Aeson
import qualified Data.Bson as B
import qualified Data.Text as T
import Data.Time.Clock
import Data.Typeable
import Database.MongoDB
import GHC.Generics
import ZGoTx
data Payment =
Payment
{ p_id :: Maybe ObjectId
, pdelta :: Integer
, pdone :: Bool
, paddress :: T.Text
, psession :: T.Text
, pblocktime :: Integer
, pamount :: Double
, ptxid :: T.Text
, pmemo :: T.Text
}
deriving (Eq, Show, Generic)
instance Val Payment where
cast' (Doc d) = do
i <- B.lookup "_id" d
delta <- B.lookup "delta" d
done <- B.lookup "done" d
a <- B.lookup "address" d
s <- B.lookup "session" d
bt <- B.lookup "blocktime" d
amt <- B.lookup "amount" d
t <- B.lookup "txid" d
m <- B.lookup "memo" d
Just (Payment i delta done a s bt amt t m)
cast' _ = Nothing
val (Payment i delta done a s bt amt t m) =
case i of
Just oid ->
Doc
[ "_id" =: oid
, "delta" =: delta
, "done" =: done
, "address" =: a
, "session" =: s
, "blocktime" =: bt
, "amount" =: amt
, "txid" =: t
, "memo" =: m
]
Nothing ->
Doc
[ "delta" =: delta
, "done" =: done
, "address" =: a
, "session" =: s
, "blocktime" =: bt
, "amount" =: amt
, "txid" =: t
, "memo" =: m
]
upsertPayment :: ZGoTx -> Action IO ()
upsertPayment p = do
let delta = sessionCalc $ 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 -> upsert (select ["tx" =: payTx] "payments") d
_ -> return ()
sessionCalc :: Double -> Integer
sessionCalc zec
| zec >= hiPay = 2419200 -- 1 month in seconds
| zec >= medPay = 604800 -- 1 week in seconds
| zec >= lowPay = 86400 -- 1 day in seconds
| otherwise = 0
where
(lowPay, medPay, hiPay) = (0.005, 0.025, 0.1)

113
src/ZGoBackend.hs
View file

@ -19,6 +19,7 @@ import Data.SecureMem
import qualified Data.Text as T
import qualified Data.Text.Lazy as L
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Typeable
import qualified Data.Vector as V
import Data.Word
@ -28,10 +29,12 @@ import GHC.Generics
import Item
import Network.HTTP.Simple
import Network.HTTP.Types.Status
import Network.Wai.Middleware.Cors
import Network.Wai.Middleware.HttpAuth
import Numeric
import Order
import Owner
import Payment
import System.IO.Unsafe
import System.Random
import Test.QuickCheck
@ -71,6 +74,16 @@ instance (FromJSON r) => FromJSON (RpcResponse r) where
MakeRpcResponse <$> obj .: "error" <*> obj .: "id" <*> obj .: "result"
parseJSON _ = mzero
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
@ -192,13 +205,13 @@ zToZGoTx (ZcashTx t a aZ bh bt c conf m) = do
then do
let sess = T.pack (fst $ head reg ! 1)
let addy = T.pack (fst $ head reg ! 2)
ZGoTx "" addy sess conf bt a t m
ZGoTx Nothing addy sess conf bt a t m
else do
if not (null reg2)
then do
let sess = T.pack (fst $ head reg2 ! 1)
ZGoTx "" "" sess conf bt a t m
else ZGoTx "" "" "" conf bt a t m
ZGoTx Nothing "" sess conf bt a t m
else ZGoTx Nothing "" "" conf bt a t m
-- |Type to model a price in the ZGo database
data ZGoPrice =
@ -304,7 +317,16 @@ upsertZGoTx coll t = do
app :: Pipe -> T.Text -> SecureMem -> T.Text -> IO ()
app pipe db passkey nodeAddress = do
let run = access pipe master db
scotty 4000 $ do
scotty 3000 $ do
middleware $
cors $
const $
Just
simpleCorsResourcePolicy
{ corsRequestHeaders = ["Authorization", "Content-Type"]
, corsMethods = "DELETE" : simpleMethods
, corsOrigins = Nothing
}
middleware $
basicAuth
(\u p -> return $ u == "user" && secureMemFromByteString p == passkey)
@ -359,18 +381,18 @@ app pipe db passkey nodeAddress = do
liftIO $ run (deleteUser userId)
status ok200
--Get txs from DB that have less than 10 confirmations
get "/api/pending" $ do
sess <- param "session"
pending <- liftIO $ run (findPending sess)
case pending of
[] -> do
status noContent204
_ -> do
Web.Scotty.json
(object
[ "message" .= ("Found pending transactions" :: String)
, "txs" .= toJSON (map parseZGoTxBson pending)
])
{-get "/api/pending" $ do-}
{-sess <- param "session"-}
{-pending <- liftIO $ run (findPending sess)-}
{-case pending of-}
{-[] -> do-}
{-status noContent204-}
{-_ -> do-}
{-Web.Scotty.json-}
{-(object-}
{-[ "message" .= ("Found pending transactions" :: String)-}
{-, "txs" .= toJSON (map parseZGoTxBson pending)-}
{-])-}
--Get current blockheight from Zcash node
get "/api/blockheight" $ do
blockInfo <- makeZcashCall "getblock" ["-1"]
@ -401,7 +423,8 @@ app pipe db passkey nodeAddress = do
--Upsert owner to DB
post "/api/owner" $ do
o <- jsonData
_ <- liftIO $ run (upsertOwner o)
let q = payload (o :: Payload Owner)
_ <- liftIO $ run (upsertOwner q)
status created201
--Get items associated with the given address
get "/api/items" $ do
@ -554,7 +577,7 @@ scanZcash addr pipe db = do
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 . upsertZGoTx "payments") j
mapM_ (access pipe master db . upsertPayment) j
-- | Function to generate users from login txs
updateLogins :: T.Text -> Pipe -> T.Text -> IO ()
@ -566,8 +589,60 @@ updateLogins addr pipe db = do
db
(rest =<<
find (select ["confirmations" =: ["$lt" =: (100 :: Integer)]] "txs"))
let parsed = map parseZGoTxBson results
let parsed = map (cast' . Doc) results
mapM_ (access pipe master db . ZGoBackend.addUser pipe db addr) parsed
putStrLn "Updated logins!"
-- | Function to mark owners as paid
checkPayments :: Pipe -> T.Text -> IO ()
checkPayments pipe db = do
qPayments <-
access pipe master db (rest =<< find (select ["done" =: False] "payments"))
let parsedPayments = map (cast' . Doc) qPayments
mapM_ (payOwner pipe db) parsedPayments
payOwner :: Pipe -> T.Text -> Maybe Payment -> IO ()
payOwner p d x =
case x of
Nothing -> return ()
Just k -> do
now <- getCurrentTime
if posixSecondsToUTCTime (fromInteger (pblocktime k + pdelta k)) <= now
then markPaymentDone p d k
else markOwnerPaid p d k
where markPaymentDone :: Pipe -> T.Text -> Payment -> IO ()
markPaymentDone pipe db pmt = do
_ <-
access
pipe
master
db
(modify
(select ["_id" =: p_id pmt] "payments")
["$set" =: ["done" =: True]])
return ()
markOwnerPaid :: Pipe -> T.Text -> Payment -> IO ()
markOwnerPaid pipe db pmt = do
user <- access pipe master db (findUser $ psession pmt)
let parsedUser = parseUserBson =<< user
let zaddy = maybe "" uaddress parsedUser
owner <- access pipe master db $ findOwner zaddy
let parsedOwner = (cast' . Doc) =<< owner
let ownerId = o_id =<< parsedOwner
_ <-
access
pipe
master
db
(modify
(select ["_id" =: ownerId] "owners")
[ "$set" =:
[ "paid" =: True
, "expiration" =:
posixSecondsToUTCTime
(fromInteger (pblocktime pmt + pdelta pmt))
]
])
markPaymentDone pipe db pmt
debug = flip trace

45
src/ZGoTx.hs
View file

@ -1,6 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
module ZGoTx where
@ -14,7 +13,7 @@ import GHC.Generics
-- | Type to model a ZGo transaction
data ZGoTx =
ZGoTx
{ _id :: String
{ _id :: Maybe ObjectId
, address :: T.Text
, session :: T.Text
, confirmations :: Integer
@ -23,7 +22,7 @@ data ZGoTx =
, txid :: T.Text
, memo :: T.Text
}
deriving (Eq, Show, Generic, ToJSON)
deriving (Eq, Show, Generic)
parseZGoTxBson :: B.Document -> Maybe ZGoTx
parseZGoTxBson d = do
@ -35,12 +34,12 @@ parseZGoTxBson d = do
t <- B.lookup "txid" d
m <- B.lookup "memo" d
bt <- B.lookup "blocktime" d
pure $ ZGoTx (show (i :: B.ObjectId)) a s c bt am t m
pure $ ZGoTx i a s c bt am t m
encodeZGoTxBson :: ZGoTx -> B.Document
encodeZGoTxBson (ZGoTx i a s c bt am t m) =
if not (null i)
then [ "_id" =: (read i :: B.ObjectId)
then [ "_id" =: i
, "address" =: a
, "session" =: s
, "confirmations" =: c
@ -57,3 +56,39 @@ encodeZGoTxBson (ZGoTx i a s c bt am t m) =
, "txid" =: t
, "memo" =: m
]
instance Val ZGoTx where
cast' (Doc d) = do
i <- B.lookup "_id" d
a <- B.lookup "address" d
s <- B.lookup "session" d
c <- B.lookup "confirmations" d
am <- B.lookup "amount" d
t <- B.lookup "txid" d
m <- B.lookup "memo" d
bt <- B.lookup "blocktime" d
Just (ZGoTx i a s c bt am t m)
cast' _ = Nothing
val (ZGoTx i a s c bt am t m) =
case i of
Just oid ->
Doc
[ "_id" =: i
, "address" =: a
, "session" =: s
, "confirmations" =: c
, "blocktime" =: bt
, "amount" =: am
, "txid" =: t
, "memo" =: m
]
Nothing ->
Doc
[ "address" =: a
, "session" =: s
, "confirmations" =: c
, "blocktime" =: bt
, "amount" =: am
, "txid" =: t
, "memo" =: m
]

72
test/Spec.hs
View file

@ -12,12 +12,16 @@ import Data.Either
import Data.Maybe
import Data.SecureMem
import qualified Data.Text as T
import Data.Time
import Data.Time.Calendar
import Data.Time.Clock
import Database.MongoDB
import Item
import Network.HTTP.Simple
import Network.HTTP.Types.Status
import Order
import Owner
import Payment
import System.IO.Unsafe
import Test.Hspec
import Test.Hspec.Expectations.Json
@ -68,7 +72,7 @@ main =
"ZGO::5d3d4494-51c0-432d-8495-050419957aea\nReply-To:\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
zToZGoTx t `shouldBe`
ZGoTx
""
Nothing
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
"5d3d4494-51c0-432d-8495-050419957aea"
20
@ -165,9 +169,15 @@ main =
res <- httpLBS req
getResponseStatus res `shouldBe` ok200
describe "Item endpoint" $ do
it "add item" $ do pending
it "get item" $ do pending
it "delete item" $ do pending
prop "add item" testItemAdd
it "get items" $ do
req <- testGet "/api/items" [("address", Just "Zaddy")]
res <- httpJSON req
getResponseStatus (res :: Response A.Value) `shouldBe` ok200
it "delete item" $ do
req <- testDelete "/api/item/" "627d7ba92b05a76be3000003"
res <- httpLBS req
getResponseStatus res `shouldBe` ok200
around handleDb $
describe "Database actions" $ do
describe "authentication" $ do
@ -252,17 +262,13 @@ main =
_ <- scanZcash nodeAddress p "test"
threadDelay 1000000
t <- access p master "test" $ findOne (select [] "payments")
case t of
Nothing -> True `shouldBe` False
Just r -> do
let s = parseZGoTxBson r
case s of
Nothing -> True `shouldBe` False
Just z -> confirmations z `shouldSatisfy` (> 0)
let s = (cast' . Doc) =<< t
let payDelta = maybe 0 pdelta s
payDelta `shouldSatisfy` (> 0)
xit "login txs are converted to users" $ \p -> do
let myTx =
ZGoTx
""
Nothing
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
"35bfb9c2-9ad2-4fe5-adda-99d63b8dcdca"
3
@ -289,7 +295,7 @@ testGet endpoint body = do
let pwd = "superSecret"
let testRequest =
setRequestQueryString body $
setRequestPort 4000 $
setRequestPort 3000 $
setRequestBasicAuth user pwd $
setRequestMethod "GET" $ setRequestPath endpoint defaultRequest
return testRequest
@ -300,7 +306,7 @@ testPost endpoint body = do
let pwd = "superSecret"
let testRequest =
setRequestQueryString body $
setRequestPort 4000 $
setRequestPort 3000 $
setRequestBasicAuth user pwd $
setRequestMethod "POST" $ setRequestPath endpoint defaultRequest
return testRequest
@ -311,7 +317,7 @@ testPostJson endpoint body = do
let pwd = "superSecret"
let testRequest =
setRequestBodyJSON body $
setRequestPort 4000 $
setRequestPort 3000 $
setRequestBasicAuth user pwd $
setRequestMethod "POST" $ setRequestPath endpoint defaultRequest
return testRequest
@ -321,7 +327,7 @@ testDelete endpoint par = do
let user = "user"
let pwd = "superSecret"
let testRequest =
setRequestPort 4000 $
setRequestPort 3000 $
setRequestBasicAuth user pwd $
setRequestMethod "DELETE" $
setRequestPath (B.append endpoint par) defaultRequest
@ -330,7 +336,8 @@ testDelete endpoint par = do
testOwnerAdd :: Owner -> Property
testOwnerAdd o =
monadicIO $ do
req <- run $ testPostJson "/api/owner" (A.toJSON o) --`debug` show o
req <-
run $ testPostJson "/api/owner" (A.object ["payload" A..= A.toJSON o]) --`debug` show o
res <- httpLBS req
assert $ getResponseStatus res == created201
@ -341,6 +348,13 @@ testOrderAdd o =
res <- httpLBS req
assert $ getResponseStatus res == created201
testItemAdd :: Item -> Property
testItemAdd i = do
monadicIO $ do
req <- run $ testPostJson "/api/item" (A.toJSON i)
res <- httpLBS req
assert $ getResponseStatus res == created201
-- | Open the MongoDB connection
openDbConnection :: IO Pipe
openDbConnection = do
@ -384,6 +398,7 @@ startAPI = do
, "pin" =: upin myUser
, "validated" =: uvalidated myUser
])
myTstamp <- getCurrentTime
let myOwner =
Owner
(Just (read "627ad3492b05a76be3000001"))
@ -407,6 +422,7 @@ startAPI = do
False
False
False
(UTCTime (fromGregorian 2022 5 16) (secondsToDiffTime 0))
_ <- access pipe master "test" (delete (select [] "owners"))
let o = val myOwner
case o of
@ -428,6 +444,16 @@ startAPI = do
let ordTest = val myOrder
case ordTest of
Doc oT -> access pipe master "test" (insert_ "orders" oT)
let myItem1 =
Item
(Just (read "627d7ba92b05a76be3000003"))
"Chair"
"Made of wood"
"Zaddy"
101.99
let itemTest = val myItem1
case itemTest of
Doc iT -> access pipe master "test" (insert_ "items" iT)
threadDelay 1000000
putStrLn "Test server is up!"
@ -479,4 +505,14 @@ instance Arbitrary Owner where
co <- arbitrary
paid <- arbitrary
zats <- arbitrary
Owner i a n c t tV v vV f l e s ct st p ph w co paid zats <$> arbitrary
inv <- arbitrary
exp <- arbitrary
pure $ Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv exp
instance Arbitrary Item where
arbitrary = do
i <- arbitrary
n <- arbitrary
d <- arbitrary
o <- arbitrary
Item i n d o <$> arbitrary

2
zgo-backend.cabal
View file

@ -28,6 +28,7 @@ library
Item
Order
Owner
Payment
User
ZGoBackend
ZGoTx
@ -55,6 +56,7 @@ library
, time
, unordered-containers
, vector
, wai-cors
, wai-extra
default-language: Haskell2010