Implement payments enhancements and tests

src/ZGoBackend.hs

@@ -1275,7 +1275,10 @@ 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
+              case foundOwner of
+                Nothing -> error "Couldn't find owner to mark as paid"
+                Just fOwn -> do
                   if pdelta pmt > 90000000
                     then do
                       _ <-
@@ -1284,14 +1287,15 @@ payOwner p d x =
                           master
                           db
                           (modify
-                         (select ["_id" =: ownerId] "owners")
+                             (select ["_id" =: o_id fOwn] "owners")
                              [ "$set" =:
                                [ "paid" =: True
                                , "invoices" =: True
                                , "expiration" =:
-                             posixSecondsToUTCTime
+                                 calculateExpiration
-                               (fromInteger
+                                   fOwn
-                                  (pblocktime pmt + pdelta pmt - 90000000))
+                                   (pdelta pmt - 90000000)
+                                   (pblocktime pmt)
                                ]
                              ])
                       markPaymentDone pipe db pmt
@@ -1302,15 +1306,24 @@ payOwner p d x =
                           master
                           db
                           (modify
-                         (select ["_id" =: ownerId] "owners")
+                             (select ["_id" =: o_id fOwn] "owners")
                              [ "$set" =:
                                [ "paid" =: True
                                , "expiration" =:
-                             posixSecondsToUTCTime
+                                 calculateExpiration
-                               (fromInteger (pblocktime pmt + pdelta pmt))
+                                   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