Merge branch 'dev'

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

Setup.hs

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

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!"

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"

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 ()

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

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.

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

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

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 <https://git.vergara.tech/Vergara_Tech//zgo-backend#readme>
 category:       Web