CHANGELOG.md

@@ -4,14 +4,6 @@ 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).
 
-## [Unreleased]
-
-### Added
-
-- New type for Pro sessions
-- New functions to save and read Pro sessions from DB
-- New function to turn off Pro session
-
 ## [1.3.0] - 2023-03-16
 
 ### Added

app/Tasks.hs

@@ -27,6 +27,5 @@ 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.4.0
+version:             1.3.0
 git:                 "https://git.vergara.tech/Vergara_Tech/zgo-backend"
 license:             BOSL
 author:              "Rene Vergara"

src/Owner.hs

@@ -301,63 +301,3 @@ 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 "expiraton" 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]
-           "owners")
-        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,15 +431,11 @@ sendPin nodeUser nodePwd nodeAddress addr pin = do
                    ]
                ])
         ]
-  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)
+  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 :("
-    Left ex ->
-      return $ "Failed to send tx to node :(" ++ show (ex :: HttpException)
 
 -- | Function to create user from ZGoTx
 addUser ::
@@ -858,8 +854,7 @@ routes pipe config = do
       else status noContent204
   --Get current blockheight from Zcash node
   get "/api/blockheight" $ do
-    blockInfo <-
-      liftAndCatchIO $ makeZcashCall nodeUser nodePwd "getblock" ["-1"]
+    blockInfo <- makeZcashCall nodeUser nodePwd "getblock" ["-1"]
     let content = getResponseBody blockInfo :: RpcResponse Block
     if isNothing (err content)
       then do
@@ -1126,21 +1121,17 @@ listTxs ::
   -> IO (Either T.Text [ZcashTx])
 listTxs user pwd a confs = do
   res <-
-    try $
+    liftIO $
     makeZcashCall
       user
       pwd
       "z_listreceivedbyaddress"
-      [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]
+      [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
+      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 ()
@@ -1271,15 +1262,14 @@ scanPayments config pipe = do
 -- | List addresses with viewing keys loaded
 listAddresses :: BS.ByteString -> BS.ByteString -> IO [ZcashAddress]
 listAddresses user pwd = do
-  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]
+  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
-    Left ex -> fail $ show ex
 
 -- | Helper function to extract addresses from AddressGroups
 getAddresses :: AddressGroup -> [ZcashAddress]
@@ -1361,16 +1351,6 @@ 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
                       _ <-
@@ -1411,19 +1391,4 @@ 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
-  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.17
+resolver: lts-20.8
   #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: 14ca51a9a597c32dd7804c10d079feea3d0ae40c5fbbb346cbd67b3ae49f6d01
-    size: 649598
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/17.yaml
-  original: lts-20.17
+    sha256: bfafe5735ccb74527d754b1f9999ded72d7c3a6c3a88529449661431ccfbd6cc
+    size: 649327
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/8.yaml
+  original: lts-20.8

test/Spec.hs

@@ -355,14 +355,6 @@ 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"
@@ -386,7 +378,7 @@ main = do
                             let t2 = ZGoBackend.timestamp r2
                             t2 `shouldSatisfy` (t1 <)
         describe "user is" $ do
-          xit "validated" $ \p -> do
+          it "validated" $ \p -> do
             t <-
               access p master "test" $
               findOne (select ["validated" =: False] "users")
@@ -481,7 +473,7 @@ main = do
             let s = parseZGoTxBson =<< t
             let conf = maybe 0 confirmations s
             conf `shouldSatisfy` (> 0)
-          xit "payments are added to db" $ \p -> do
+          it "payments are added to db" $ \p -> do
             _ <-
               access
                 p
@@ -778,16 +770,6 @@ 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.1.
+-- This file has been generated from package.yaml by hpack version 0.35.0.
 --
 -- see: https://github.com/sol/hpack
 
 name:           zgo-backend
-version:        1.4.0
+version:        1.3.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