Implement user creation and PINs

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

package.yaml

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

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
+    { u_id :: String
-    , address :: T.Text
+    , uaddress :: T.Text
-    , session :: T.Text
+    , usession :: T.Text
-    , blocktime :: Integer
+    , ublocktime :: Integer
-    , pin :: T.Text
+    , upin :: T.Text
-    , validated :: Bool
+    , 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 :: Pipe -> T.Text -> T.Text -> Maybe ZGoTx -> Action IO ()
-addUser node (ZGoTx i a s c bt am t m) = do
+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
+        [ "address" =: address tx
-    , "session" =: s
+        , "session" =: session tx
-    , "blocktime" =: bt
+        , "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!"
+    then return "Pin sent!"
-    else putStrLn "Pin sending failed :("
+    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

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

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