Implement user creation and PINs

This commit is contained in:
Rene Vergara 2022-05-03 08:59:29 -05:00
parent 3acaa7e487
commit 71450efc2e
Signed by: pitmutt
GPG key ID: 65122AD495A7F5B2
5 changed files with 80 additions and 35 deletions

View file

@ -3,19 +3,9 @@
module Main where
import Control.Concurrent (forkIO, threadDelay)
import Control.Monad
import Control.Monad.IO.Class
import Data.Aeson
import qualified Data.ByteString as B
import Data.SecureMem
import qualified Data.Text as T
import qualified Data.Text.Lazy as L
import Database.MongoDB
import GHC.Generics
import Network.HTTP.Simple
import Network.HTTP.Types.Status
import Network.Wai.Middleware.HttpAuth
import Web.Scotty
import ZGoBackend
passkey :: SecureMem

View file

@ -54,6 +54,7 @@ executables:
- -threaded
- -rtsopts
- -with-rtsopts=-N
- -Wall
dependencies:
- zgo-backend
- base

View file

@ -14,12 +14,14 @@ 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 qualified Data.Vector as V
import Database.MongoDB
import Debug.Trace
import GHC.Generics
import Network.HTTP.Simple
import Network.HTTP.Types.Status
@ -187,12 +189,12 @@ parseCountryBson d = do
-- | Type to represent a ZGo User, i.e.: a specific device
data User =
User
{ _id :: String
, address :: T.Text
, session :: T.Text
, blocktime :: Integer
, pin :: T.Text
, validated :: Bool
{ u_id :: String
, uaddress :: T.Text
, usession :: T.Text
, ublocktime :: Integer
, upin :: T.Text
, uvalidated :: Bool
}
deriving (Eq, Show, Generic, ToJSON)
@ -281,7 +283,7 @@ data ZGoPrice =
{ _id :: String
, currency :: T.Text
, price :: Double
, timestamp :: String
, timestamp :: UTCTime
}
deriving (Eq, Show, Generic, ToJSON)
@ -291,7 +293,7 @@ parseZGoPrice d = do
c <- B.lookup "currency" d
p <- B.lookup "price" d
t <- B.lookup "timestamp" d
pure $ ZGoPrice (show (i :: B.ObjectId)) c p (show (t :: B.Value))
pure $ ZGoPrice (show (i :: B.ObjectId)) c p t
-- | Type for the CoinGecko response
newtype CoinGeckoPrices =
@ -314,20 +316,25 @@ findUser :: T.Text -> Action IO (Maybe Document)
findUser s = findOne (select ["session" =: s] "users")
-- | Function to create user from ZGoTx
addUser :: T.Text -> ZGoTx -> Action IO ()
addUser node (ZGoTx i a s c bt am t m) = do
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
if isNew
then do
let newPin = unsafePerformIO generatePin
let msg = sendPin node a newPin
_ <- sendPin node (address tx) newPin
insert_
"users"
[ "address" =: a
, "session" =: s
, "blocktime" =: bt
[ "address" =: address tx
, "session" =: session tx
, "blocktime" =: blocktime tx
, "pin" =: newPin
, "validated" =: False
]
else return ()
sendPin :: T.Text -> T.Text -> T.Text -> IO ()
sendPin :: T.Text -> T.Text -> T.Text -> Action IO String
sendPin nodeAddress addr pin = do
let payload =
[ Data.Aeson.String nodeAddress
@ -336,15 +343,15 @@ sendPin nodeAddress addr pin = do
[ object
[ "address" .= addr
, "amount" .= (0.00000001 :: Double)
, "memo" .= pin
, "memo" .= encodeHexText ("ZGo PIN: " ++ T.unpack (pin))
]
])
]
r <- makeZcashCall "z_sendmany" payload
let sCode = getResponseStatus (r :: Response Object)
if sCode == ok200
then putStrLn "Pin sent!"
else putStrLn "Pin sending failed :("
then return "Pin sent!"
else return "Pin sending failed :("
-- | Function to query DB for transactions with less than 10 confirmations
findPending :: String -> Action IO [Document]
@ -509,11 +516,13 @@ getZcashPrices = do
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
r <- makeZcashCall "z_listreceivedbyaddress" [Data.Aeson.String addr]
@ -530,3 +539,25 @@ scanZcash addr pipe db = do
mapM_ (access pipe master db . upsertZGoTx "txs") k
let j = map zToZGoTx (filter (matchTest p . T.unpack . zmemo) txs)
mapM_ (access pipe master db . upsertZGoTx "payments") 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 parseZGoTxBson results
mapM_ (access pipe master db . ZGoBackend.addUser pipe db addr) parsed
putStrLn "Updated logins!"
isUserNew :: Pipe -> T.Text -> ZGoTx -> IO Bool
isUserNew p db tx = do
res <-
(access p master db (findOne (select ["session" =: (session tx)] "users")))
return $ isNothing res
debug = flip trace

View file

@ -166,6 +166,29 @@ main =
case s of
Nothing -> True `shouldBe` False
Just z -> confirmations z `shouldSatisfy` (> 0)
it "login txs are converted to users" $ \p -> do
let myTx =
ZGoTx
""
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
"35bfb9c2-9ad2-4fe5-adda-99d63b8dcdca"
3
1613487
0.00000001
"abcdef"
"Super Memo"
_ <- access p master "test" (delete (select [] "users"))
_ <- access p master "test" (insert_ "txs" (encodeZGoTxBson myTx))
_ <- updateLogins nodeAddress p "test"
threadDelay 1000000
t <- access p master "test" $ findOne (select [] "users")
case t of
Nothing -> True `shouldBe` False
Just r -> do
let s = parseUserBson r
case s of
Nothing -> True `shouldBe` False
Just z -> length (T.unpack (usession z)) `shouldSatisfy` (> 0)
testGet :: B.ByteString -> [(B.ByteString, Maybe B.ByteString)] -> IO Request
testGet endpoint body = do

View file

@ -59,7 +59,7 @@ executable zgo-backend-exe
Paths_zgo_backend
hs-source-dirs:
app
ghc-options: -threaded -rtsopts -with-rtsopts=-N
ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall
build-depends:
aeson
, base