659 lines
20 KiB
Haskell
659 lines
20 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE DeriveAnyClass #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
|
|
module ZGoBackend where
|
|
|
|
import Control.Concurrent (forkIO, threadDelay)
|
|
import Control.Monad
|
|
import Control.Monad.IO.Class
|
|
import Data.Aeson
|
|
import Data.Array
|
|
import qualified Data.Bson as B
|
|
import qualified Data.ByteString as BS
|
|
import Data.Char
|
|
import qualified Data.HashMap.Strict as HM
|
|
import Data.Maybe
|
|
import Data.SecureMem
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Lazy as L
|
|
import Data.Time.Clock
|
|
import Data.Time.Clock.POSIX
|
|
import Data.Typeable
|
|
import qualified Data.Vector as V
|
|
import Data.Word
|
|
import Database.MongoDB
|
|
import Debug.Trace
|
|
import GHC.Generics
|
|
import Item
|
|
import Network.HTTP.Simple
|
|
import Network.HTTP.Types.Status
|
|
import Network.Wai.Middleware.Cors
|
|
import Network.Wai.Middleware.HttpAuth
|
|
import Numeric
|
|
import Order
|
|
import Owner
|
|
import Payment
|
|
import System.IO.Unsafe
|
|
import System.Random
|
|
import Test.QuickCheck
|
|
import Test.QuickCheck.Instances
|
|
import Text.Regex
|
|
import Text.Regex.Base
|
|
import User
|
|
import Web.Scotty
|
|
import ZGoTx
|
|
|
|
-- Models for API objects
|
|
-- | A type to model Zcash RPC calls
|
|
data RpcCall =
|
|
RpcCall
|
|
{ jsonrpc :: T.Text
|
|
, callId :: T.Text
|
|
, method :: T.Text
|
|
, parameters :: [Data.Aeson.Value]
|
|
}
|
|
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
|
|
|
|
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
|
|
|
|
-- | 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
|
|
{ ztxid :: T.Text
|
|
, zamount :: Double
|
|
, zamountZat :: Integer
|
|
, zblockheight :: Integer
|
|
, zblocktime :: Integer
|
|
, zchange :: Bool
|
|
, zconfirmations :: Integer
|
|
, zmemo :: T.Text
|
|
}
|
|
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"
|
|
pure $
|
|
ZcashTx
|
|
t
|
|
a
|
|
aZ
|
|
bh
|
|
bt
|
|
c
|
|
conf
|
|
(T.pack (filter (/= '\NUL') $ decodeHexText m))
|
|
|
|
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
|
|
]
|
|
|
|
instance Arbitrary ZcashTx where
|
|
arbitrary = do
|
|
a <- arbitrary
|
|
aZ <- arbitrary
|
|
t <- arbitrary
|
|
bh <- arbitrary
|
|
bt <- arbitrary
|
|
c <- arbitrary
|
|
cm <- arbitrary
|
|
ZcashTx a aZ t bh bt c cm <$> arbitrary
|
|
|
|
-- | Helper function to turn a hex-encoded memo strings to readable text
|
|
decodeHexText :: String -> String
|
|
decodeHexText hexText
|
|
-- | chunk == "00" = decodeHexText (drop 2 hexText)
|
|
| null chunk = ""
|
|
| otherwise = chr (read ("0x" <> chunk)) : decodeHexText (drop 2 hexText)
|
|
where
|
|
chunk = take 2 hexText
|
|
|
|
-- | Helper function to turn a string into a hex-encoded string
|
|
encodeHexText :: String -> String
|
|
encodeHexText t = mconcat (map padHex t)
|
|
where
|
|
padHex x =
|
|
if ord x < 16
|
|
then "0" ++ (showHex . ord) x ""
|
|
else showHex (ord x) ""
|
|
|
|
-- 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
|
|
|
|
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
|
|
let sess = T.pack (fst $ head reg ! 1)
|
|
let addy = T.pack (fst $ head reg ! 2)
|
|
ZGoTx Nothing addy sess conf bt a t m
|
|
else do
|
|
if not (null reg2)
|
|
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
|
|
|
|
-- |Type to model a price in the ZGo database
|
|
data ZGoPrice =
|
|
ZGoPrice
|
|
{ _id :: String
|
|
, currency :: T.Text
|
|
, price :: Double
|
|
, timestamp :: UTCTime
|
|
}
|
|
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
|
|
pure $ ZGoPrice (show (i :: B.ObjectId)) c p t
|
|
|
|
-- | 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")
|
|
|
|
sendPin :: T.Text -> T.Text -> T.Text -> Action IO String
|
|
sendPin nodeAddress addr pin = do
|
|
let payload =
|
|
[ Data.Aeson.String nodeAddress
|
|
, Data.Aeson.Array
|
|
(V.fromList
|
|
[ object
|
|
[ "address" .= addr
|
|
, "amount" .= (0.00000001 :: Double)
|
|
, "memo" .= encodeHexText ("ZGo PIN: " ++ T.unpack pin)
|
|
]
|
|
])
|
|
]
|
|
r <- makeZcashCall "z_sendmany" payload
|
|
let sCode = getResponseStatus (r :: Response Object)
|
|
if sCode == ok200
|
|
then return "Pin sent!"
|
|
else return "Pin sending failed :("
|
|
|
|
-- | Function to create user from ZGoTx
|
|
addUser :: Pipe -> T.Text -> T.Text -> Maybe ZGoTx -> Action IO ()
|
|
addUser _ _ _ Nothing = return () --`debug` "addUser got Nothing"
|
|
addUser p db node (Just tx) = do
|
|
isNew <- liftIO $ isUserNew p db tx
|
|
when isNew $ do
|
|
let newPin = unsafePerformIO generatePin
|
|
_ <- sendPin node (address tx) newPin
|
|
insert_
|
|
"users"
|
|
[ "address" =: address tx
|
|
, "session" =: session tx
|
|
, "blocktime" =: blocktime tx
|
|
, "pin" =: newPin
|
|
, "validated" =: False
|
|
]
|
|
|
|
-- | Function to query DB for transactions with less than 10 confirmations
|
|
findPending :: String -> Action IO [Document]
|
|
findPending s =
|
|
rest =<<
|
|
find
|
|
(select ["session" =: s, "confirmations" =: ["$lt" =: (3 :: Integer)]] "txs")
|
|
|
|
-- | 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]
|
|
|
|
-- | 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)
|
|
|
|
-- | Main API routes
|
|
routes :: Pipe -> T.Text -> SecureMem -> T.Text -> ScottyM ()
|
|
routes pipe db passkey nodeAddress = do
|
|
let run = access pipe master db
|
|
middleware $
|
|
cors $
|
|
const $
|
|
Just
|
|
simpleCorsResourcePolicy
|
|
{ corsRequestHeaders = ["Authorization", "Content-Type"]
|
|
, corsMethods = "DELETE" : simpleMethods
|
|
, corsOrigins = Nothing
|
|
}
|
|
middleware $
|
|
basicAuth
|
|
(\u p -> return $ u == "user" && secureMemFromByteString p == passkey)
|
|
"ZGo Backend"
|
|
--Get list of countries for UI
|
|
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)
|
|
])
|
|
--Get user associated with session
|
|
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
|
|
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))
|
|
--Delete user
|
|
Web.Scotty.delete "/api/user/:id" $ do
|
|
userId <- param "id"
|
|
liftIO $ run (deleteUser userId)
|
|
status ok200
|
|
--Get txs from DB that have less than 10 confirmations
|
|
{-get "/api/pending" $ do-}
|
|
{-sess <- param "session"-}
|
|
{-pending <- liftIO $ run (findPending sess)-}
|
|
{-case pending of-}
|
|
{-[] -> do-}
|
|
{-status noContent204-}
|
|
{-_ -> do-}
|
|
{-Web.Scotty.json-}
|
|
{-(object-}
|
|
{-[ "message" .= ("Found pending transactions" :: String)-}
|
|
{-, "txs" .= toJSON (map parseZGoTxBson pending)-}
|
|
{-])-}
|
|
--Get current blockheight from Zcash node
|
|
get "/api/blockheight" $ do
|
|
blockInfo <- makeZcashCall "getblock" ["-1"]
|
|
Web.Scotty.json (result (getResponseBody blockInfo :: RpcResponse Block))
|
|
--Get transactions associated with ZGo node
|
|
--get "/api/txs" $ do
|
|
--txs <- makeZcashCall "z_listreceivedbyaddress" [nodeAddress]
|
|
--Web.Scotty.json (result (getResponseBody txs :: RpcResponse [ZcashTx]))
|
|
--Get the ZGo node's shielded address
|
|
get "/api/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress])
|
|
--Get owner by address
|
|
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)
|
|
])
|
|
--Upsert owner to DB
|
|
post "/api/owner" $ do
|
|
o <- jsonData
|
|
let q = payload (o :: Payload Owner)
|
|
_ <- liftIO $ run (upsertOwner q)
|
|
status created201
|
|
--Get items associated with the given address
|
|
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])
|
|
--Upsert item
|
|
post "/api/item" $ do
|
|
i <- jsonData
|
|
let q = payload (i :: Payload Item)
|
|
_ <- liftIO $ run (upsertItem q)
|
|
status created201
|
|
--Delete item
|
|
Web.Scotty.delete "/api/item/:id" $ do
|
|
oId <- param "id"
|
|
liftIO $ run (deleteItem oId)
|
|
status ok200
|
|
--Get price for Zcash
|
|
get "/api/price" $ do
|
|
curr <- param "currency"
|
|
pr <- liftIO $ run (findPrice curr)
|
|
case pr of
|
|
Nothing -> do
|
|
status noContent204
|
|
--Web.Scotty.json (object ["message" .= ("No price" :: T.Text)])
|
|
Just p -> do
|
|
Web.Scotty.json
|
|
(object
|
|
[ "message" .= ("Price found!" :: String)
|
|
, "price" .= toJSON (parseZGoPrice p)
|
|
])
|
|
--Get all closed orders for the address
|
|
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
|
|
])
|
|
--Get order by id for receipts
|
|
get "/api/order/:id" $ do
|
|
oId <- param "id"
|
|
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)
|
|
])
|
|
--Get order by session
|
|
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)
|
|
])
|
|
--Upsert order
|
|
post "/api/order" $ do
|
|
newOrder <- jsonData
|
|
let q = payload (newOrder :: Payload ZGoOrder)
|
|
_ <- liftIO $ run (upsertOrder q)
|
|
status created201
|
|
--Delete order
|
|
Web.Scotty.delete "/api/order/:id" $ do
|
|
oId <- param "id"
|
|
liftIO $ run (deleteOrder oId)
|
|
status ok200
|
|
|
|
-- |Make a Zcash RPC call
|
|
makeZcashCall ::
|
|
(MonadIO m, FromJSON a) => T.Text -> [Data.Aeson.Value] -> m (Response a)
|
|
makeZcashCall m p = do
|
|
let username = "zecwallet"
|
|
let password = "rdsxlun6v4a"
|
|
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
|
|
|
|
-- | Function to update the Zcash prices in the ZGo db
|
|
checkZcashPrices :: Pipe -> T.Text -> IO ()
|
|
checkZcashPrices p db = do
|
|
q <- getZcashPrices
|
|
mapM_ (access p master db) (updatePrices (getResponseBody q))
|
|
|
|
-- | Function to check the ZGo full node for new txs
|
|
scanZcash :: T.Text -> Pipe -> T.Text -> IO ()
|
|
scanZcash addr pipe db = do
|
|
res <- makeZcashCall "z_listreceivedbyaddress" [Data.Aeson.String addr]
|
|
let txs =
|
|
filter (not . zchange) $
|
|
result (getResponseBody res :: RpcResponse [ZcashTx])
|
|
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)
|
|
mapM_ (access pipe master db . upsertPayment) j
|
|
|
|
-- | Function to generate users from login txs
|
|
updateLogins :: T.Text -> Pipe -> T.Text -> IO ()
|
|
updateLogins addr pipe db = do
|
|
results <-
|
|
access
|
|
pipe
|
|
master
|
|
db
|
|
(rest =<<
|
|
find (select ["confirmations" =: ["$lt" =: (100 :: Integer)]] "txs"))
|
|
let parsed = map (cast' . Doc) results
|
|
mapM_ (access pipe master db . ZGoBackend.addUser pipe db addr) parsed
|
|
putStrLn "Updated logins!"
|
|
|
|
-- | 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
|
|
|
|
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 ()
|
|
|
|
debug = flip trace
|