diff --git a/app/Main.hs b/app/Main.hs index e26fa6a..5d03d03 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/package.yaml b/package.yaml index 29b155c..b998d3c 100644 --- a/package.yaml +++ b/package.yaml @@ -54,6 +54,7 @@ executables: - -threaded - -rtsopts - -with-rtsopts=-N + - -Wall dependencies: - zgo-backend - base diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 6b834b1..48e28d7 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -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 - let newPin = unsafePerformIO generatePin - let msg = sendPin node a newPin - insert_ - "users" - [ "address" =: a - , "session" =: s - , "blocktime" =: bt - , "pin" =: newPin - , "validated" =: False - ] +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 + _ <- sendPin node (address tx) newPin + insert_ + "users" + [ "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 diff --git a/test/Spec.hs b/test/Spec.hs index 9422dc4..7799624 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 diff --git a/zgo-backend.cabal b/zgo-backend.cabal index 6cb5d6c..9346a5a 100644 --- a/zgo-backend.cabal +++ b/zgo-backend.cabal @@ -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