diff --git a/CHANGELOG.md b/CHANGELOG.md index 06645e8..49acd4e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 index 9a994af..0000000 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/app/Tasks.hs b/app/Tasks.hs index c3360a8..0f8a12d 100644 --- a/app/Tasks.hs +++ b/app/Tasks.hs @@ -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!" diff --git a/package.yaml b/package.yaml index 631b58e..0b70d38 100644 --- a/package.yaml +++ b/package.yaml @@ -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" diff --git a/src/Owner.hs b/src/Owner.hs index 2e85222..f426636 100644 --- a/src/Owner.hs +++ b/src/Owner.hs @@ -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 () diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 17bb653..6b52d25 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -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 diff --git a/stack.yaml b/stack.yaml index 48755d1..442eff8 100644 --- a/stack.yaml +++ b/stack.yaml @@ -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. diff --git a/stack.yaml.lock b/stack.yaml.lock index f3f90bb..358549d 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs index b549218..4527b03 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 diff --git a/zgo-backend.cabal b/zgo-backend.cabal index 270d63d..6671448 100644 --- a/zgo-backend.cabal +++ b/zgo-backend.cabal @@ -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 category: Web