diff --git a/src/Order.hs b/src/Order.hs index ce38f85..d04b97c 100644 --- a/src/Order.hs +++ b/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 () diff --git a/src/Payment.hs b/src/Payment.hs index c836c39..193b48e 100644 --- a/src/Payment.hs +++ b/src/Payment.hs @@ -66,30 +66,12 @@ instance Val Payment where , "memo" =: m ] -upsertPayment :: ZGoTx -> Action IO () -upsertPayment p = do - let delta = sessionCalc $ 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 -> 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 +sessionCalc :: Double -> Double -> Integer +sessionCalc p zec + | p * zec >= 0.95 * proPay = 92419200 + | p * zec >= 0.95 * hiPay = 2419200 -- 1 month in seconds + | p * zec >= 0.95 * medPay = 604800 -- 1 week in seconds + | p * zec >= 0.95 * 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) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 6214127..ab9bf8d 100644 --- a/src/ZGoBackend.hs +++ b/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,7 +339,13 @@ 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 ZGoTx Nothing "" "" 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 data ZGoPrice = @@ -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,23 +1006,41 @@ 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 =<< parsedOwner - _ <- - access - pipe - master - db - (modify - (select ["_id" =: ownerId] "owners") - [ "$set" =: - [ "paid" =: True - , "expiration" =: - posixSecondsToUTCTime - (fromInteger (pblocktime pmt + pdelta pmt)) - ] - ]) - markPaymentDone pipe db pmt + let ownerId = o_id =<< (cast' . Doc) =<< owner + 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 + master + db + (modify + (select ["_id" =: ownerId] "owners") + [ "$set" =: + [ "paid" =: True + , "expiration" =: + posixSecondsToUTCTime + (fromInteger (pblocktime pmt + pdelta pmt)) + ] + ]) + markPaymentDone pipe db pmt expireOwners :: Pipe -> T.Text -> IO () expireOwners pipe db = do