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

Merge branch 'dev'

This commit is contained in:
Rene Vergara 2023-05-02 15:20:55 -05:00
parent b2d58ca035 c7b738e2da
commit d550c9d432
Signed by: pitmutt
GPG Key ID: 65122AD495A7F5B2
10 changed files with 167 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
CHANGELOG.md
View File

@ -4,6 +4,18 @@ All notable changes to this project will be documented in this file.
The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),
and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html).
## [1.4.0] - 2023-05-02
### Added
- New type for Pro sessions
- New functions to save and read Pro sessions from DB
- New function to turn off Pro session
### Fixed
- Handling of potential failures of RPC calls to `zcashd` ([#6](https://git.vergara.tech/Vergara_Tech/zgo-backend/issues/6)).
## [1.3.0] - 2023-03-16
### Added

2
Setup.hs
View File

@ -1,2 +0,0 @@
import Distribution.Simple
main = defaultMain

1
app/Tasks.hs
View File

@ -27,5 +27,6 @@ main = do
checkPayments pipe (c_dbName loadedConfig)
expireOwners pipe (c_dbName loadedConfig)
updateLogins pipe loadedConfig
expireProSessions pipe (c_dbName loadedConfig)
close pipe
else fail "MongoDB connection failed!"

2
package.yaml
View File

@ -1,5 +1,5 @@
name: zgo-backend
version: 1.3.0
version: 1.4.0
git: "https://git.vergara.tech/Vergara_Tech/zgo-backend"
license: BOSL
author: "Rene Vergara"

60
src/Owner.hs
View File

@ -301,3 +301,63 @@ findExpiringOwners now =
(select
["paid" =: True, "expiration" =: ["$lte" =: addUTCTime 172800 now]]
"owners")
removePro :: T.Text -> Action IO ()
removePro o =
modify (select ["address" =: o] "owners") ["$set" =: ["invoices" =: False]]
-- | Type for a pro session
data ZGoProSession =
ZGoProSession
{ ps_id :: Maybe ObjectId
, psaddress :: T.Text
, psexpiration :: UTCTime
, psclosed :: Bool
}
deriving (Eq, Show)
instance Val ZGoProSession where
cast' (Doc d) = do
i <- B.lookup "_id" d
a <- B.lookup "address" d
e <- B.lookup "expiration" d
p <- B.lookup "closed" d
Just (ZGoProSession i a e p)
cast' _ = Nothing
val (ZGoProSession i a e p) =
case i of
Just oid ->
Doc ["_id" =: oid, "address" =: a, "expiration" =: e, "closed" =: p]
Nothing -> Doc ["address" =: a, "expiration" =: e, "closed" =: p]
-- | Function to get a pro session
findProSession :: T.Text -> Action IO (Maybe Document)
findProSession zaddy =
findOne (select ["address" =: zaddy, "closed" =: False] "prosessions")
-- | Function to get expiring pro sessions
findExpiringProSessions :: UTCTime -> Action IO [Document]
findExpiringProSessions now =
rest =<<
find
(select ["closed" =: False, "expiration" =: ["$lte" =: now]] "prosessions")
-- | Function to upsert a pro session
upsertProSession :: ZGoProSession -> Action IO ()
upsertProSession ps = do
let prosession = val ps
case prosession of
Doc d ->
upsert
(select
["address" =: psaddress ps, "expiration" =: psexpiration ps]
"prosessions")
d
_ -> return ()
closeProSession :: ZGoProSession -> Action IO ()
closeProSession ps = do
let prosession = val ps
case prosession of
Doc d -> modify (select d "prosessions") ["$set" =: ["closed" =: True]]
_ -> return ()

88
src/ZGoBackend.hs
View File

@ -431,11 +431,15 @@ sendPin nodeUser nodePwd nodeAddress addr pin = do
]
])
]
r <- makeZcashCall nodeUser nodePwd "z_sendmany" pd
let sCode = getResponseStatus (r :: Response Object)
if sCode == ok200
then return "Pin sent!"
else return "Pin sending failed :("
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 ::
@ -519,9 +523,16 @@ upsertPayment pipe dbName p = do
(memo p)
let payment = val payTx
case payment of
Doc d ->
access pipe master dbName $
upsert (select ["txid" =: txid p] "payments") d
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
@ -854,7 +865,8 @@ routes pipe config = do
else status noContent204
--Get current blockheight from Zcash node
get "/api/blockheight" $ do
blockInfo <- makeZcashCall nodeUser nodePwd "getblock" ["-1"]
blockInfo <-
liftAndCatchIO $ makeZcashCall nodeUser nodePwd "getblock" ["-1"]
let content = getResponseBody blockInfo :: RpcResponse Block
if isNothing (err content)
then do
@ -1121,17 +1133,21 @@ listTxs ::
-> IO (Either T.Text [ZcashTx])
listTxs user pwd a confs = do
res <-
liftIO $
try $
makeZcashCall
user
pwd
"z_listreceivedbyaddress"
[Data.Aeson.String a, Data.Aeson.Number $ Scientific.scientific confs 0]
let content = getResponseBody res :: RpcResponse [ZcashTx]
case err content of
Nothing ->
return $ Right $ filter (not . zchange) $ fromMaybe [] $ result content
Just e -> return $ Left $ "Error reading transactions: " <> emessage e
[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 check the ZGo full node for new txs
scanZcash :: Config -> Pipe -> IO ()
@ -1262,14 +1278,15 @@ scanPayments config pipe = do
-- | 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]
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]
@ -1325,6 +1342,7 @@ payOwner p d x =
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
@ -1351,6 +1369,16 @@ payOwner p d x =
(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
_ <-
@ -1391,4 +1419,20 @@ expireOwners pipe db = do
["$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
debug = flip trace

2
stack.yaml
View File

@ -17,7 +17,7 @@
#
# resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml
resolver: lts-20.8
resolver: lts-20.17
#url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/4.yaml
# User packages to be built.

8
stack.yaml.lock
View File

@ -31,7 +31,7 @@ packages:
hackage: crypto-rng-0.3.0.1@sha256:04f4ae75943ecad8b794950985054130f272d65a588b6b6528f56df0bfedc4dc,1565
snapshots:
- completed:
sha256: bfafe5735ccb74527d754b1f9999ded72d7c3a6c3a88529449661431ccfbd6cc
size: 649327
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/8.yaml
original: lts-20.8
sha256: 14ca51a9a597c32dd7804c10d079feea3d0ae40c5fbbb346cbd67b3ae49f6d01
size: 649598
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/17.yaml
original: lts-20.17

22
test/Spec.hs
View File

@ -355,6 +355,14 @@ main = do
it "should fail with bad creds" $ \p -> do
r <- liftIO $ access p master "zgo" (auth "user" "pwd")
r `shouldBe` False
describe "ZGo Pro sessions" $ do
it "find in DB" $ \p -> do
doc <-
access p master "test" $
findProSession
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
doc `shouldNotBe` Nothing
it "upsert to DB" $ const pending
describe "Zcash prices" $ do
it "should update" $ \p -> do
doc <- access p master "test" $ findPrice "usd"
@ -378,7 +386,7 @@ main = do
let t2 = ZGoBackend.timestamp r2
t2 `shouldSatisfy` (t1 <)
describe "user is" $ do
it "validated" $ \p -> do
xit "validated" $ \p -> do
t <-
access p master "test" $
findOne (select ["validated" =: False] "users")
@ -473,7 +481,7 @@ main = do
let s = parseZGoTxBson =<< t
let conf = maybe 0 confirmations s
conf `shouldSatisfy` (> 0)
it "payments are added to db" $ \p -> do
xit "payments are added to db" $ \p -> do
_ <-
access
p
@ -770,6 +778,16 @@ startAPI config = do
case itemTest of
Doc iT -> access pipe master "test" (insert_ "items" iT)
_ -> fail "Couldn't save test Item in DB"
let proSession1 =
ZGoProSession
Nothing
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
myTs
False
let proSessionTest = val proSession1
case proSessionTest of
Doc pS1 -> access pipe master "test" (insert_ "prosessions" pS1)
_ -> fail "Couldn't save test ZGoProSession in DB"
--let myWooToken =
--WooToken
--Nothing

4
zgo-backend.cabal
View File

@ -1,11 +1,11 @@
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.35.0.
-- This file has been generated from package.yaml by hpack version 0.35.1.
--
-- see: https://github.com/sol/hpack
name: zgo-backend
version: 1.3.0
version: 1.4.0
synopsis: Haskell Back-end for the ZGo point-of-sale application
description: Please see the README at <https://git.vergara.tech/Vergara_Tech//zgo-backend#readme>
category: Web