Implement payments enhancements and tests

src/ZGoBackend.hs

@@ -1275,42 +1275,55 @@ payOwner p d x =
               let parsedUser = parseUserBson =<< user
               let zaddy = maybe "" uaddress parsedUser
               owner <- access pipe master db $ findOwner zaddy
-              let ownerId = o_id =<< (cast' . Doc) =<< owner
+              let foundOwner = (cast' . Doc) =<< owner
-              if pdelta pmt > 90000000
+              case foundOwner of
-                then do
+                Nothing -> error "Couldn't find owner to mark as paid"
-                  _ <-
+                Just fOwn -> do
-                    access
+                  if pdelta pmt > 90000000
-                      pipe
+                    then do
-                      master
+                      _ <-
-                      db
+                        access
-                      (modify
+                          pipe
-                         (select ["_id" =: ownerId] "owners")
+                          master
-                         [ "$set" =:
+                          db
-                           [ "paid" =: True
+                          (modify
-                           , "invoices" =: True
+                             (select ["_id" =: o_id fOwn] "owners")
-                           , "expiration" =:
+                             [ "$set" =:
-                             posixSecondsToUTCTime
+                               [ "paid" =: True
-                               (fromInteger
+                               , "invoices" =: True
-                                  (pblocktime pmt + pdelta pmt - 90000000))
+                               , "expiration" =:
-                           ]
+                                 calculateExpiration
-                         ])
+                                   fOwn
-                  markPaymentDone pipe db pmt
+                                   (pdelta pmt - 90000000)
-                else do
+                                   (pblocktime pmt)
-                  _ <-
+                               ]
-                    access
+                             ])
-                      pipe
+                      markPaymentDone pipe db pmt
-                      master
+                    else do
-                      db
+                      _ <-
-                      (modify
+                        access
-                         (select ["_id" =: ownerId] "owners")
+                          pipe
-                         [ "$set" =:
+                          master
-                           [ "paid" =: True
+                          db
-                           , "expiration" =:
+                          (modify
-                             posixSecondsToUTCTime
+                             (select ["_id" =: o_id fOwn] "owners")
-                               (fromInteger (pblocktime pmt + pdelta pmt))
+                             [ "$set" =:
-                           ]
+                               [ "paid" =: True
-                         ])
+                               , "expiration" =:
-                  markPaymentDone pipe db pmt
+                                 calculateExpiration
+                                   fOwn
+                                   (pdelta pmt)
+                                   (pblocktime pmt)
+                               ]
+                             ])
+                      markPaymentDone pipe db pmt
+            calculateExpiration :: Owner -> Integer -> Integer -> UTCTime
+            calculateExpiration o delta blocktime =
+              if opaid o
+                then addUTCTime
+                       (secondsToNominalDiffTime (fromIntegral delta))
+                       (oexpiration o)
+                else posixSecondsToUTCTime (fromIntegral $ delta + blocktime)
 
 expireOwners :: Pipe -> T.Text -> IO ()
 expireOwners pipe db = do

test/Spec.hs

@@ -454,7 +454,7 @@ main = do
             let s = (cast' . Doc) =<< t
             let payDelta = maybe 0 pdelta s
             payDelta `shouldSatisfy` (> 0)
-          xit "owners are marked as paid" $ \p -> do
+          it "owners are marked as paid" $ \p -> do
             let myUser =
                   User
                     (Just (read "6272a90f2b05a74cf1000002" :: ObjectId))
@@ -697,34 +697,7 @@ startAPI config = do
           True
           False
           False
-          (UTCTime (fromGregorian 2022 4 16) (secondsToDiffTime 0))
+          (UTCTime (fromGregorian 2023 2 6) (secondsToDiffTime 0))
-          False
-          ""
-          ""
-  let myOwner1 =
-        Owner
-          (Just (read "627ad3492b05a76be5000001"))
-          "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
-          "Test shop"
-          "usd"
-          False
-          0
-          False
-          0
-          "Bubba"
-          "Gibou"
-          "bubba@zgo.cash"
-          "1 Main St"
-          "Mpls"
-          "Minnesota"
-          "55401"
-          ""
-          "bubbarocks.io"
-          "United States"
-          True
-          False
-          False
-          (UTCTime (fromGregorian 2022 4 16) (secondsToDiffTime 0))
           False
           ""
           ""

zgo-backend.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           zgo-backend
-version:        1.2.2
+version:        1.2.3
 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