zgo-backend/src/ZGoBackend.hs

676 lines
20 KiB
Haskell
Raw Normal View History

2022-04-22 16:15:23 +00:00
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
module ZGoBackend where
2022-04-30 12:59:49 +00:00
import Control.Concurrent (forkIO, threadDelay)
2022-04-22 16:15:23 +00:00
import Control.Monad
import Control.Monad.IO.Class
import Data.Aeson
2022-04-30 12:59:49 +00:00
import Data.Array
2022-04-22 16:15:23 +00:00
import qualified Data.Bson as B
2022-04-30 12:59:49 +00:00
import qualified Data.ByteString as BS
2022-04-22 16:15:23 +00:00
import Data.Char
import qualified Data.HashMap.Strict as HM
2022-07-07 15:33:53 +00:00
import Data.HexString
2022-05-03 13:59:29 +00:00
import Data.Maybe
2022-04-30 12:59:49 +00:00
import Data.SecureMem
2022-04-22 16:15:23 +00:00
import qualified Data.Text as T
2022-07-07 15:13:33 +00:00
import qualified Data.Text.Encoding as E
import Data.Text.Encoding.Error (lenientDecode)
2022-04-30 12:59:49 +00:00
import qualified Data.Text.Lazy as L
2022-04-22 16:15:23 +00:00
import Data.Time.Clock
2022-05-17 17:47:27 +00:00
import Data.Time.Clock.POSIX
2022-05-11 20:04:46 +00:00
import Data.Typeable
2022-04-30 12:59:49 +00:00
import qualified Data.Vector as V
2022-05-11 20:04:46 +00:00
import Data.Word
2022-04-22 16:15:23 +00:00
import Database.MongoDB
2022-05-03 13:59:29 +00:00
import Debug.Trace
2022-04-22 16:15:23 +00:00
import GHC.Generics
2022-05-12 19:59:29 +00:00
import Item
2022-04-30 12:59:49 +00:00
import Network.HTTP.Simple
import Network.HTTP.Types.Status
2022-05-17 17:47:27 +00:00
import Network.Wai.Middleware.Cors
2022-04-30 12:59:49 +00:00
import Network.Wai.Middleware.HttpAuth
import Numeric
2022-05-11 20:04:46 +00:00
import Order
import Owner
2022-05-17 17:47:27 +00:00
import Payment
2022-04-30 12:59:49 +00:00
import System.IO.Unsafe
import System.Random
import Test.QuickCheck
import Test.QuickCheck.Instances
import Text.Regex
import Text.Regex.Base
2022-05-11 20:04:46 +00:00
import User
2022-04-30 12:59:49 +00:00
import Web.Scotty
2022-05-11 20:04:46 +00:00
import ZGoTx
2022-04-22 16:15:23 +00:00
-- Models for API objects
-- | A type to model Zcash RPC calls
data RpcCall =
RpcCall
{ jsonrpc :: T.Text
, callId :: T.Text
, method :: T.Text
2022-04-30 12:59:49 +00:00
, parameters :: [Data.Aeson.Value]
2022-04-22 16:15:23 +00:00
}
deriving (Show, Generic)
instance ToJSON RpcCall where
toJSON (RpcCall j c m p) =
object ["jsonrpc" .= j, "id" .= c, "method" .= m, "params" .= p]
-- | A type to model the response of the Zcash RPC
data RpcResponse r =
MakeRpcResponse
{ err :: Maybe T.Text
, respId :: T.Text
, result :: r
}
deriving (Show, Generic, ToJSON)
instance (FromJSON r) => FromJSON (RpcResponse r) where
parseJSON (Object obj) =
MakeRpcResponse <$> obj .: "error" <*> obj .: "id" <*> obj .: "result"
parseJSON _ = mzero
2022-05-17 17:47:27 +00:00
data Payload r =
Payload
{ payload :: r
}
deriving (Show, Generic, ToJSON)
instance (FromJSON r) => FromJSON (Payload r) where
parseJSON (Object obj) = Payload <$> obj .: "payload"
parseJSON _ = mzero
2022-04-22 16:15:23 +00:00
-- | Type to model a (simplified) block of Zcash blockchain
data Block =
Block
{ height :: Integer
, size :: Integer
}
deriving (Show, Generic, ToJSON)
instance FromJSON Block where
parseJSON (Object obj) = Block <$> obj .: "height" <*> obj .: "size"
parseJSON _ = mzero
-- | Type to model a Zcash shielded transaction
data ZcashTx =
ZcashTx
2022-04-30 12:59:49 +00:00
{ ztxid :: T.Text
, zamount :: Double
, zamountZat :: Integer
, zblockheight :: Integer
, zblocktime :: Integer
, zchange :: Bool
, zconfirmations :: Integer
, zmemo :: T.Text
2022-04-22 16:15:23 +00:00
}
deriving (Show, Generic)
instance FromJSON ZcashTx where
parseJSON =
withObject "ZcashTx" $ \obj -> do
t <- obj .: "txid"
a <- obj .: "amount"
aZ <- obj .: "amountZat"
bh <- obj .: "blockheight"
bt <- obj .: "blocktime"
c <- obj .: "change"
conf <- obj .: "confirmations"
m <- obj .: "memo"
2022-04-30 12:59:49 +00:00
pure $
2022-07-07 15:13:33 +00:00
ZcashTx t a aZ bh bt c conf (T.filter (/= '\NUL') $ decodeHexText m)
2022-04-22 16:15:23 +00:00
instance ToJSON ZcashTx where
toJSON (ZcashTx t a aZ bh bt c conf m) =
object
[ "amount" .= a
, "amountZat" .= aZ
, "txid" .= t
, "blockheight" .= bh
, "blocktime" .= bt
, "change" .= c
, "confirmations" .= conf
, "memo" .= m
]
2022-04-30 12:59:49 +00:00
instance Arbitrary ZcashTx where
arbitrary = do
a <- arbitrary
aZ <- arbitrary
t <- arbitrary
bh <- arbitrary
bt <- arbitrary
c <- arbitrary
cm <- arbitrary
2022-05-11 20:04:46 +00:00
ZcashTx a aZ t bh bt c cm <$> arbitrary
2022-04-30 12:59:49 +00:00
2022-04-22 16:15:23 +00:00
-- | Helper function to turn a hex-encoded memo strings to readable text
2022-07-07 15:13:33 +00:00
decodeHexText :: String -> T.Text
decodeHexText h = E.decodeUtf8With lenientDecode $ BS.pack $ hexRead h
2022-04-22 16:15:23 +00:00
where
2022-07-07 15:13:33 +00:00
hexRead hexText
| null chunk = []
| otherwise =
fromIntegral (read ("0x" <> chunk)) : hexRead (drop 2 hexText)
where
chunk = take 2 hexText
2022-04-22 16:15:23 +00:00
2022-04-30 12:59:49 +00:00
-- | Helper function to turn a string into a hex-encoded string
2022-07-07 15:33:53 +00:00
encodeHexText :: T.Text -> String
encodeHexText t = T.unpack . toText . fromBytes $ E.encodeUtf8 t
2022-04-30 12:59:49 +00:00
2022-04-22 16:15:23 +00:00
-- Types for the ZGo database documents
-- | Type to model a country for the database's country list
data Country =
Country
{ _id :: String
, name :: T.Text
, code :: T.Text
}
deriving (Eq, Show, Generic, ToJSON)
parseCountryBson :: B.Document -> Maybe Country
parseCountryBson d = do
i <- B.lookup "_id" d
n <- B.lookup "name" d
c <- B.lookup "code" d
pure $ Country (show (i :: B.ObjectId)) n c
2022-04-30 12:59:49 +00:00
zToZGoTx :: ZcashTx -> ZGoTx
zToZGoTx (ZcashTx t a aZ bh bt c conf m) = do
let r =
mkRegex
".*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})\\sReply-To:\\s(zs[a-z0-9]{76}).*"
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 reg = matchAllText r (T.unpack m)
let reg2 = matchAllText p (T.unpack m)
if not (null reg)
then do
2022-05-11 20:04:46 +00:00
let sess = T.pack (fst $ head reg ! 1)
2022-04-30 12:59:49 +00:00
let addy = T.pack (fst $ head reg ! 2)
2022-05-17 17:47:27 +00:00
ZGoTx Nothing addy sess conf bt a t m
2022-04-30 12:59:49 +00:00
else do
if not (null reg2)
then do
2022-05-11 20:04:46 +00:00
let sess = T.pack (fst $ head reg2 ! 1)
2022-05-17 17:47:27 +00:00
ZGoTx Nothing "" sess conf bt a t m
else ZGoTx Nothing "" "" conf bt a t m
2022-04-22 16:15:23 +00:00
-- |Type to model a price in the ZGo database
data ZGoPrice =
ZGoPrice
{ _id :: String
, currency :: T.Text
, price :: Double
2022-05-03 13:59:29 +00:00
, timestamp :: UTCTime
2022-04-22 16:15:23 +00:00
}
deriving (Eq, Show, Generic, ToJSON)
parseZGoPrice :: B.Document -> Maybe ZGoPrice
parseZGoPrice d = do
i <- B.lookup "_id" d
c <- B.lookup "currency" d
p <- B.lookup "price" d
t <- B.lookup "timestamp" d
2022-05-03 13:59:29 +00:00
pure $ ZGoPrice (show (i :: B.ObjectId)) c p t
2022-04-22 16:15:23 +00:00
-- | Type for the CoinGecko response
newtype CoinGeckoPrices =
CoinGeckoPrices [(T.Text, Double)]
deriving (Eq, Show)
instance FromJSON CoinGeckoPrices where
parseJSON =
withObject "CoinGeckoPrices" $ \obj -> do
z <- obj .: "zcash"
pure $ CoinGeckoPrices (HM.toList z)
-- Functions for querying the ZGo database
-- | Function to query DB for countries list
listCountries :: Action IO [Document]
listCountries = rest =<< find (select [] "countries")
2022-05-19 17:56:56 +00:00
sendPin ::
BS.ByteString
-> BS.ByteString
-> T.Text
-> T.Text
-> T.Text
-> Action IO String
sendPin nodeUser nodePwd nodeAddress addr pin = do
2022-05-24 15:20:10 +00:00
let pd =
2022-04-30 12:59:49 +00:00
[ Data.Aeson.String nodeAddress
, Data.Aeson.Array
(V.fromList
[ object
[ "address" .= addr
, "amount" .= (0.00000001 :: Double)
2022-07-07 15:33:53 +00:00
, "memo" .= encodeHexText ("ZGo PIN: " <> pin)
2022-04-30 12:59:49 +00:00
]
])
]
2022-05-24 15:20:10 +00:00
r <- makeZcashCall nodeUser nodePwd "z_sendmany" pd
2022-04-30 12:59:49 +00:00
let sCode = getResponseStatus (r :: Response Object)
if sCode == ok200
2022-05-03 13:59:29 +00:00
then return "Pin sent!"
else return "Pin sending failed :("
2022-04-22 16:15:23 +00:00
2022-05-11 20:04:46 +00:00
-- | Function to create user from ZGoTx
2022-05-19 17:56:56 +00:00
addUser ::
BS.ByteString
-> BS.ByteString
-> Pipe
-> T.Text
-> T.Text
-> Maybe ZGoTx
-> Action IO ()
addUser _ _ _ _ _ Nothing = return () --`debug` "addUser got Nothing"
addUser nodeUser nodePwd p db node (Just tx) = do
2022-05-11 20:04:46 +00:00
isNew <- liftIO $ isUserNew p db tx
when isNew $ do
let newPin = unsafePerformIO generatePin
2022-05-19 17:56:56 +00:00
_ <- sendPin nodeUser nodePwd node (address tx) newPin
2022-05-11 20:04:46 +00:00
insert_
"users"
[ "address" =: address tx
, "session" =: session tx
, "blocktime" =: blocktime tx
, "pin" =: newPin
, "validated" =: False
]
2022-04-22 16:15:23 +00:00
-- | Function to query DB for transactions with less than 10 confirmations
findPending :: String -> Action IO [Document]
findPending s =
rest =<<
find
2022-04-30 12:59:49 +00:00
(select ["session" =: s, "confirmations" =: ["$lt" =: (3 :: Integer)]] "txs")
2022-04-22 16:15:23 +00:00
-- | Function to query DB for price by currency
findPrice :: String -> Action IO (Maybe Document)
findPrice c = findOne (select ["currency" =: c] "prices")
-- | Function to update prices in ZGo db
updatePrices :: CoinGeckoPrices -> [Action IO ()]
updatePrices (CoinGeckoPrices []) = []
updatePrices (CoinGeckoPrices x) = do
updateOnePrice (head x) : updatePrices (CoinGeckoPrices (tail x))
-- | Function to update one price in ZGo db
updateOnePrice :: (T.Text, Double) -> Action IO ()
updateOnePrice (c, v) = do
t <- liftIO getCurrentTime
upsert
(select ["currency" =: c] "prices")
["currency" =: c, "price" =: v, "timestamp" =: t]
2022-04-30 12:59:49 +00:00
-- | Function to upsert ZGoTxs into the given collection
upsertZGoTx :: T.Text -> ZGoTx -> Action IO ()
upsertZGoTx coll t = do
upsert (select ["txid" =: txid t] coll) (encodeZGoTxBson t)
2022-05-19 14:52:17 +00:00
-- | Main API routes
2022-05-19 17:56:56 +00:00
routes ::
Pipe
-> T.Text
-> SecureMem
-> T.Text
-> BS.ByteString
-> BS.ByteString
-> ScottyM ()
routes pipe db passkey nodeAddress nodeUser nodePwd = do
2022-04-30 12:59:49 +00:00
let run = access pipe master db
2022-05-19 14:52:17 +00:00
middleware $
cors $
const $
Just
simpleCorsResourcePolicy
{ corsRequestHeaders = ["Authorization", "Content-Type"]
, corsMethods = "DELETE" : simpleMethods
2022-05-24 15:20:10 +00:00
--, corsOrigins = Nothing
2022-05-19 14:52:17 +00:00
}
middleware $
basicAuth
(\u p -> return $ u == "user" && secureMemFromByteString p == passkey)
"ZGo Backend"
2022-04-30 12:59:49 +00:00
--Get list of countries for UI
2022-05-19 14:52:17 +00:00
get "/api/countries" $ do
countries <- liftIO $ run listCountries
case countries of
[] -> do
status noContent204
_ -> do
Web.Scotty.json
(object
[ "message" .= ("Country data found" :: String)
, "countries" .= toJSON (map parseCountryBson countries)
])
2022-04-30 12:59:49 +00:00
--Get user associated with session
2022-05-19 14:52:17 +00:00
get "/api/user" $ do
sess <- param "session"
user <- liftIO $ run (findUser sess)
case user of
Nothing -> status noContent204
Just u ->
Web.Scotty.json
(object
[ "message" .= ("User found" :: String)
, "user" .= toJSON (parseUserBson u)
])
--Validate user, updating record
2022-05-19 14:52:17 +00:00
post "/api/validateuser" $ do
providedPin <- param "pin"
sess <- param "session"
user <- liftIO $ run (findUser sess)
case user of
Nothing -> status noContent204 --`debug` "No user match"
Just u -> do
let parsedUser = parseUserBson u
case parsedUser of
Nothing -> status noContent204 --`debug` "Couldn't parse user"
Just pUser -> do
let ans = upin pUser == T.pack providedPin
if ans
then do
liftIO $ run (validateUser sess)
status accepted202
else status noContent204 --`debug` ("Pins didn't match: " ++ providedPin ++ " " ++ T.unpack (upin pUser))
2022-04-30 12:59:49 +00:00
--Delete user
2022-05-19 14:52:17 +00:00
Web.Scotty.delete "/api/user/:id" $ do
userId <- param "id"
2022-05-24 15:20:10 +00:00
let r = mkRegex "^[a-f0-9]{24}$"
if matchTest r userId
then do
liftIO $ run (deleteUser userId)
status ok200
2022-05-24 18:10:01 +00:00
else status noContent204
2022-05-24 15:20:10 +00:00
--Get current blockheight from Zcash node
2022-05-19 14:52:17 +00:00
get "/api/blockheight" $ do
2022-05-19 17:56:56 +00:00
blockInfo <- makeZcashCall nodeUser nodePwd "getblock" ["-1"]
2022-05-19 14:52:17 +00:00
Web.Scotty.json (result (getResponseBody blockInfo :: RpcResponse Block))
2022-05-24 15:20:10 +00:00
--Get the ZGo node's shielded address
2022-05-19 14:52:17 +00:00
get "/api/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress])
2022-05-24 15:20:10 +00:00
--Get owner by address
2022-05-19 14:52:17 +00:00
get "/api/owner" $ do
addr <- param "address"
owner <- liftIO $ run (findOwner addr)
case owner of
Nothing -> status noContent204
Just o -> do
let pOwner = cast' (Doc o)
case pOwner of
Nothing -> status internalServerError500
Just q -> do
status ok200
Web.Scotty.json
(object
[ "message" .= ("Owner found!" :: String)
, "owner" .= toJSON (q :: Owner)
])
2022-05-24 15:20:10 +00:00
--Upsert owner to DB
2022-05-19 14:52:17 +00:00
post "/api/owner" $ do
o <- jsonData
let q = payload (o :: Payload Owner)
_ <- liftIO $ run (upsertOwner q)
status created201
2022-04-30 12:59:49 +00:00
--Get items associated with the given address
2022-05-19 14:52:17 +00:00
get "/api/items" $ do
addr <- param "address"
items <- liftIO $ run (findItems addr)
case items of
[] -> status noContent204
_ -> do
let pItems = map (cast' . Doc) items :: [Maybe Item]
status ok200
Web.Scotty.json
(object
["message" .= ("Items found!" :: String), "items" .= toJSON pItems])
2022-04-30 12:59:49 +00:00
--Upsert item
2022-05-19 14:52:17 +00:00
post "/api/item" $ do
i <- jsonData
let q = payload (i :: Payload Item)
_ <- liftIO $ run (upsertItem q)
status created201
2022-04-30 12:59:49 +00:00
--Delete item
2022-05-19 14:52:17 +00:00
Web.Scotty.delete "/api/item/:id" $ do
oId <- param "id"
2022-05-24 15:20:10 +00:00
let r = mkRegex "^[a-f0-9]{24}$"
if matchTest r oId
then do
liftIO $ run (deleteItem oId)
status ok200
2022-05-24 18:10:01 +00:00
else status noContent204
2022-04-30 12:59:49 +00:00
--Get price for Zcash
2022-05-19 14:52:17 +00:00
get "/api/price" $ do
curr <- param "currency"
pr <- liftIO $ run (findPrice curr)
case pr of
Nothing -> do
status noContent204
Just p -> do
Web.Scotty.json
(object
[ "message" .= ("Price found!" :: String)
, "price" .= toJSON (parseZGoPrice p)
])
2022-04-30 12:59:49 +00:00
--Get all closed orders for the address
2022-05-19 14:52:17 +00:00
get "/api/allorders" $ do
addr <- param "address"
myOrders <- liftIO $ run (findAllOrders addr)
case myOrders of
[] -> status noContent204
_ -> do
let pOrders = map (cast' . Doc) myOrders :: [Maybe ZGoOrder]
status ok200
Web.Scotty.json
(object
[ "message" .= ("Orders found!" :: String)
, "orders" .= toJSON pOrders
])
2022-04-30 12:59:49 +00:00
--Get order by id for receipts
2022-05-19 14:52:17 +00:00
get "/api/order/:id" $ do
oId <- param "id"
2022-05-24 15:20:10 +00:00
let r = mkRegex "^[a-f0-9]{24}$"
if matchTest r oId
then do
myOrder <- liftIO $ run (findOrderById oId)
case myOrder of
Nothing -> status noContent204
Just o -> do
let o' = cast' (Doc o)
case o' of
Nothing -> status internalServerError500
Just pOrder -> do
status ok200
Web.Scotty.json
(object
[ "message" .= ("Order found!" :: String)
, "order" .= toJSON (pOrder :: ZGoOrder)
])
2022-05-24 18:10:01 +00:00
else status noContent204
2022-04-30 12:59:49 +00:00
--Get order by session
2022-05-19 14:52:17 +00:00
get "/api/order" $ do
sess <- param "session"
myOrder <- liftIO $ run (findOrder sess)
case myOrder of
Nothing -> status noContent204
Just o -> do
let o' = cast' (Doc o)
case o' of
Nothing -> status internalServerError500
Just pOrder -> do
status ok200
Web.Scotty.json
(object
[ "message" .= ("Order found!" :: String)
, "order" .= toJSON (pOrder :: ZGoOrder)
])
2022-04-30 12:59:49 +00:00
--Upsert order
2022-05-19 14:52:17 +00:00
post "/api/order" $ do
newOrder <- jsonData
let q = payload (newOrder :: Payload ZGoOrder)
_ <- liftIO $ run (upsertOrder q)
status created201
2022-05-11 20:04:46 +00:00
--Delete order
2022-05-19 14:52:17 +00:00
Web.Scotty.delete "/api/order/:id" $ do
oId <- param "id"
liftIO $ run (deleteOrder oId)
status ok200
2022-04-30 12:59:49 +00:00
-- |Make a Zcash RPC call
makeZcashCall ::
2022-05-19 17:56:56 +00:00
(MonadIO m, FromJSON a)
=> BS.ByteString
-> BS.ByteString
-> T.Text
-> [Data.Aeson.Value]
-> m (Response a)
makeZcashCall username password m p = do
2022-04-30 12:59:49 +00:00
let payload =
RpcCall {jsonrpc = "1.0", callId = "test", method = m, parameters = p}
let myRequest =
setRequestBodyJSON payload $
setRequestPort 8232 $
setRequestBasicAuth username password $
setRequestMethod "POST" defaultRequest
httpJSON myRequest
-- |Timer for repeating actions
setInterval :: Int -> IO () -> IO ()
setInterval secs func = do
forever $ threadDelay (secs * 1000000) >> func
-- |Function to query the CoinGecko API for the price of Zcash
getZcashPrices :: IO (Response CoinGeckoPrices)
getZcashPrices = do
let priceRequest =
setRequestQueryString
[("ids", Just "zcash"), ("vs_currencies", Just "usd,gbp,eur,cad,aud")] $
setRequestPort 443 $
setRequestSecure True $
setRequestHost "api.coingecko.com" $
setRequestPath "/api/v3/simple/price" defaultRequest
httpJSON priceRequest
2022-05-03 13:59:29 +00:00
-- | Function to update the Zcash prices in the ZGo db
2022-04-30 12:59:49 +00:00
checkZcashPrices :: Pipe -> T.Text -> IO ()
checkZcashPrices p db = do
q <- getZcashPrices
mapM_ (access p master db) (updatePrices (getResponseBody q))
2022-05-03 13:59:29 +00:00
-- | Function to check the ZGo full node for new txs
2022-05-19 17:56:56 +00:00
scanZcash :: T.Text -> Pipe -> T.Text -> BS.ByteString -> BS.ByteString -> IO ()
scanZcash addr pipe db nodeUser nodePwd = do
res <-
makeZcashCall
nodeUser
nodePwd
"z_listreceivedbyaddress"
[Data.Aeson.String addr]
2022-04-30 12:59:49 +00:00
let txs =
filter (not . zchange) $
2022-05-11 20:04:46 +00:00
result (getResponseBody res :: RpcResponse [ZcashTx])
2022-04-30 12:59:49 +00:00
let r =
mkRegex
".*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})\\sReply-To:\\s(zs[a-z0-9]{76}).*"
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 k = map zToZGoTx (filter (matchTest r . T.unpack . zmemo) txs)
mapM_ (access pipe master db . upsertZGoTx "txs") k
let j = map zToZGoTx (filter (matchTest p . T.unpack . zmemo) txs)
2022-05-17 17:47:27 +00:00
mapM_ (access pipe master db . upsertPayment) j
2022-05-03 13:59:29 +00:00
-- | Function to generate users from login txs
2022-05-19 17:56:56 +00:00
updateLogins ::
BS.ByteString -> BS.ByteString -> T.Text -> Pipe -> T.Text -> IO ()
updateLogins nodeUser nodePwd addr pipe db = do
2022-05-03 13:59:29 +00:00
results <-
access
pipe
master
db
(rest =<<
find (select ["confirmations" =: ["$lt" =: (100 :: Integer)]] "txs"))
2022-05-17 17:47:27 +00:00
let parsed = map (cast' . Doc) results
2022-05-19 17:56:56 +00:00
mapM_
(access pipe master db . ZGoBackend.addUser nodeUser nodePwd pipe db addr)
parsed
2022-05-03 13:59:29 +00:00
putStrLn "Updated logins!"
2022-05-17 17:47:27 +00:00
-- | Function to mark owners as paid
checkPayments :: Pipe -> T.Text -> IO ()
checkPayments pipe db = do
qPayments <-
access pipe master db (rest =<< find (select ["done" =: False] "payments"))
let parsedPayments = map (cast' . Doc) qPayments
mapM_ (payOwner pipe db) parsedPayments
payOwner :: Pipe -> T.Text -> Maybe Payment -> IO ()
payOwner p d x =
case x of
Nothing -> return ()
Just k -> do
now <- getCurrentTime
if posixSecondsToUTCTime (fromInteger (pblocktime k + pdelta k)) <= now
then markPaymentDone p d k
else markOwnerPaid p d k
where markPaymentDone :: Pipe -> T.Text -> Payment -> IO ()
markPaymentDone pipe db pmt = do
_ <-
access
pipe
master
db
(modify
(select ["_id" =: p_id pmt] "payments")
["$set" =: ["done" =: True]])
return ()
markOwnerPaid :: Pipe -> T.Text -> Payment -> IO ()
markOwnerPaid pipe db pmt = do
user <- access pipe master db (findUser $ psession pmt)
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
2022-05-17 20:06:38 +00:00
expireOwners :: Pipe -> T.Text -> IO ()
expireOwners pipe db = do
now <- getCurrentTime
_ <-
access
pipe
master
db
(modify
(select ["expiration" =: ["$lt" =: now]] "owners")
["$set" =: ["paid" =: False]])
return ()
2022-05-03 13:59:29 +00:00
debug = flip trace