Fix order endpoint bug

src/Order.hs

@@ -185,7 +185,10 @@ upsertOrder :: ZGoOrder -> Action IO ()
 upsertOrder o = do
   let order = val $ updateOrderTotals o
   case order of
-    Doc d -> upsert (select ["_id" =: q_id o] "orders") d
+    Doc d -> 
+      if isJust (q_id o)
+         then upsert (select ["_id" =: q_id o] "orders") d
+         else insert_ "orders" d
     _ -> return ()
 
 upsertXeroOrder :: ZGoOrder -> Action IO ()

src/Payment.hs

@@ -66,30 +66,12 @@ instance Val Payment where
           , "memo" =: m
           ]
 
-upsertPayment :: ZGoTx -> Action IO ()
+sessionCalc :: Double -> Double -> Integer
-upsertPayment p = do
+sessionCalc p zec
-  let delta = sessionCalc $ amount p
+  | p * zec >= 0.95 * proPay = 92419200
-  let payTx =
+  | p * zec >= 0.95 * hiPay = 2419200 -- 1 month in seconds
-        Payment
+  | p * zec >= 0.95 * medPay = 604800 -- 1 week in seconds
-          Nothing
+  | p * zec >= 0.95 * lowPay = 86400 -- 1 day in seconds
-          delta
-          False
-          (address p)
-          (session p)
-          (blocktime p)
-          (amount p)
-          (txid p)
-          (memo p)
-  let payment = val payTx
-  case payment of
-    Doc d -> upsert (select ["txid" =: txid p] "payments") d
-    _ -> return ()
-
-sessionCalc :: Double -> Integer
-sessionCalc zec
-  | zec >= hiPay = 2419200 -- 1 month in seconds
-  | zec >= medPay = 604800 -- 1 week in seconds
-  | zec >= lowPay = 86400 -- 1 day in seconds
   | otherwise = 0
   where
-    (lowPay, medPay, hiPay) = (0.005, 0.025, 0.1)
+    (lowPay, medPay, hiPay, proPay) = (1, 6, 22, 30)

src/ZGoBackend.hs

@@ -323,8 +323,12 @@ zToZGoTx (ZcashTx t a aZ bh bt c conf m) = do
   let p =
         mkRegex
           ".*ZGOp::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12}).*"
+  let y =
+        mkRegex
+          ".*MSG\\s(zs[a-z0-9]{76}).*ZGO::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12}).*"
   let reg = matchAllText r (T.unpack m)
   let reg2 = matchAllText p (T.unpack m)
+  let reg3 = matchAllText y (T.unpack m)
   if not (null reg)
     then do
       let sess = T.pack (fst $ head reg ! 1)
@@ -335,6 +339,12 @@ zToZGoTx (ZcashTx t a aZ bh bt c conf m) = do
         then do
           let sess = T.pack (fst $ head reg2 ! 1)
           ZGoTx Nothing "" sess conf bt a t m
+        else do
+          if not (null reg3)
+            then do
+              let sess = T.pack (fst $ head reg ! 2)
+              let nAddy = T.pack (fst $ head reg ! 1)
+              ZGoTx Nothing nAddy sess conf bt a t m
             else ZGoTx Nothing "" "" conf bt a t m
 
 -- |Type to model a price in the ZGo database
@@ -450,6 +460,33 @@ upsertZGoTx :: T.Text -> ZGoTx -> Action IO ()
 upsertZGoTx coll t = do
   upsert (select ["txid" =: txid t] coll) (encodeZGoTxBson t)
 
+-- | Function to upsert payment
+upsertPayment :: Pipe -> T.Text -> ZGoTx -> IO ()
+upsertPayment pipe dbName p = do
+  zecData <- access pipe master dbName (findPrice "usd")
+  let zecPrice = parseZGoPrice =<< zecData
+  case zecPrice of
+    Nothing -> error "Failed to fetch ZEC price"
+    Just zp -> do
+      let delta = sessionCalc (price zp) (amount p)
+      let payTx =
+            Payment
+              Nothing
+              delta
+              False
+              (address p)
+              (session p)
+              (blocktime p)
+              (amount p)
+              (txid p)
+              (memo p)
+      let payment = val payTx
+      case payment of
+        Doc d ->
+          access pipe master dbName $
+          upsert (select ["txid" =: txid p] "payments") d
+        _ -> return ()
+
 -- | Main API routes
 routes :: Pipe -> Config -> ScottyM ()
 routes pipe config = do
@@ -857,10 +894,15 @@ scanZcash config pipe = do
       let p =
             mkRegex
               ".*ZGOp::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12}).*"
+      let y =
+            mkRegex
+              ".*MSG\\s(zs[a-z0-9]{76}).*ZGO::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12}).*"
       let k = map zToZGoTx (filter (isRelevant r) txs)
       mapM_ (access pipe master (c_dbName config) . upsertZGoTx "txs") k
       let j = map zToZGoTx (filter (isRelevant p) txs)
-      mapM_ (access pipe master (c_dbName config) . upsertPayment) j
+      mapM_ (upsertPayment pipe (c_dbName config)) j
+      let l = map zToZGoTx (filter (isRelevant y) txs)
+      mapM_ (access pipe master (c_dbName config) . upsertZGoTx "txs") l
     Left e -> do
       putStrLn $ "Error scanning node transactions: " ++ T.unpack e
       return ()
@@ -964,8 +1006,26 @@ payOwner p d x =
               let parsedUser = parseUserBson =<< user
               let zaddy = maybe "" uaddress parsedUser
               owner <- access pipe master db $ findOwner zaddy
-              let parsedOwner = (cast' . Doc) =<< owner
+              let ownerId = o_id =<< (cast' . Doc) =<< owner
-              let ownerId = o_id =<< parsedOwner
+              if pdelta pmt > 90000000
+                then do
+                  _ <-
+                    access
+                      pipe
+                      master
+                      db
+                      (modify
+                         (select ["_id" =: ownerId] "owners")
+                         [ "$set" =:
+                           [ "paid" =: True
+                           , "expiration" =:
+                             posixSecondsToUTCTime
+                               (fromInteger
+                                  (pblocktime pmt + pdelta pmt - 90000000))
+                           ]
+                         ])
+                  markPaymentDone pipe db pmt
+                else do
                   _ <-
                     access
                       pipe