diff --git a/app/Main.hs b/app/Main.hs index 5d03d03..bf6302b 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -26,7 +26,8 @@ main = do putStrLn "Starting Server..." pipe <- connect $ host "127.0.0.1" j <- access pipe master "zgo" (auth dbUser dbPassword) - {-_ <- forkIO (setInterval 60 (checkZcashPrices pipe))-} + _ <- forkIO (setInterval 60 (checkZcashPrices pipe "zgo")) + _ <- forkIO (setInterval 75 (scanZcash nodeAddress pipe "zgo")) if j then putStrLn "Connected to MongoDB!" else fail "MongoDB connection failed!" diff --git a/package.yaml b/package.yaml index f83a955..5b23cf0 100644 --- a/package.yaml +++ b/package.yaml @@ -45,6 +45,7 @@ library: - array - random - vector + - wai-cors executables: zgo-backend-exe: diff --git a/src/Owner.hs b/src/Owner.hs index 3cce76d..c2acc6e 100644 --- a/src/Owner.hs +++ b/src/Owner.hs @@ -7,6 +7,7 @@ module Owner where import Data.Aeson import qualified Data.Bson as B import qualified Data.Text as T +import Data.Time.Clock import Data.Typeable import Database.MongoDB import GHC.Generics @@ -35,11 +36,12 @@ data Owner = , opaid :: Bool , ozats :: Bool , oinvoices :: Bool + , oexpiration :: UTCTime } deriving (Eq, Show, Generic, Typeable) instance ToJSON Owner where - toJSON (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv) = + toJSON (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv eTs) = case i of Just oid -> object @@ -64,6 +66,7 @@ instance ToJSON Owner where , "paid" .= paid , "zats" .= zats , "invoices" .= inv + , "expiration" .= eTs ] Nothing -> object @@ -88,6 +91,7 @@ instance ToJSON Owner where , "paid" .= paid , "zats" .= zats , "invoices" .= inv + , "expiration" .= eTs ] instance FromJSON Owner where @@ -114,6 +118,7 @@ instance FromJSON Owner where paid <- obj .: "paid" zats <- obj .: "zats" inv <- obj .: "invoices" + ets <- obj .: "expiration" pure $ Owner (if not (null i) @@ -139,6 +144,7 @@ instance FromJSON Owner where paid zats inv + ets instance Val Owner where cast' (Doc d) = do @@ -163,9 +169,10 @@ instance Val Owner where paid <- B.lookup "paid" d zats <- B.lookup "zats" d inv <- B.lookup "invoices" d - Just (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv) + ets <- B.lookup "expiration" d + Just (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv ets) cast' _ = Nothing - val (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv) = + val (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv ets) = case i of Just oid -> Doc @@ -190,6 +197,7 @@ instance Val Owner where , "paid" =: paid , "zats" =: zats , "invoices" =: inv + , "expiration" =: ets ] Nothing -> Doc @@ -213,6 +221,7 @@ instance Val Owner where , "paid" =: paid , "zats" =: zats , "invoices" =: inv + , "expiration" =: ets ] -- Database actions diff --git a/src/Payment.hs b/src/Payment.hs new file mode 100644 index 0000000..ed41bce --- /dev/null +++ b/src/Payment.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module Payment where + +import Data.Aeson +import qualified Data.Bson as B +import qualified Data.Text as T +import Data.Time.Clock +import Data.Typeable +import Database.MongoDB +import GHC.Generics +import ZGoTx + +data Payment = + Payment + { p_id :: Maybe ObjectId + , pdelta :: Integer + , pdone :: Bool + , paddress :: T.Text + , psession :: T.Text + , pblocktime :: Integer + , pamount :: Double + , ptxid :: T.Text + , pmemo :: T.Text + } + deriving (Eq, Show, Generic) + +instance Val Payment where + cast' (Doc d) = do + i <- B.lookup "_id" d + delta <- B.lookup "delta" d + done <- B.lookup "done" d + a <- B.lookup "address" d + s <- B.lookup "session" d + bt <- B.lookup "blocktime" d + amt <- B.lookup "amount" d + t <- B.lookup "txid" d + m <- B.lookup "memo" d + Just (Payment i delta done a s bt amt t m) + cast' _ = Nothing + val (Payment i delta done a s bt amt t m) = + case i of + Just oid -> + Doc + [ "_id" =: oid + , "delta" =: delta + , "done" =: done + , "address" =: a + , "session" =: s + , "blocktime" =: bt + , "amount" =: amt + , "txid" =: t + , "memo" =: m + ] + Nothing -> + Doc + [ "delta" =: delta + , "done" =: done + , "address" =: a + , "session" =: s + , "blocktime" =: bt + , "amount" =: amt + , "txid" =: t + , "memo" =: m + ] + +upsertPayment :: ZGoTx -> Action IO () +upsertPayment p = do + let delta = sessionCalc $ amount p + let payTx = + Payment + Nothing + delta + False + (address p) + (session p) + (blocktime p) + (amount p) + (txid p) + (memo p) + let payment = val payTx + case payment of + Doc d -> upsert (select ["tx" =: payTx] "payments") d + _ -> return () + +sessionCalc :: Double -> Integer +sessionCalc zec + | zec >= hiPay = 2419200 -- 1 month in seconds + | zec >= medPay = 604800 -- 1 week in seconds + | zec >= lowPay = 86400 -- 1 day in seconds + | otherwise = 0 + where + (lowPay, medPay, hiPay) = (0.005, 0.025, 0.1) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index dc823ac..947fe42 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -19,6 +19,7 @@ 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 @@ -28,10 +29,12 @@ 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 @@ -71,6 +74,16 @@ instance (FromJSON r) => FromJSON (RpcResponse r) where 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 @@ -192,13 +205,13 @@ zToZGoTx (ZcashTx t a aZ bh bt c conf m) = do then do let sess = T.pack (fst $ head reg ! 1) let addy = T.pack (fst $ head reg ! 2) - ZGoTx "" addy sess conf bt a t m + 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 "" "" sess conf bt a t m - else ZGoTx "" "" "" conf bt a t m + 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 = @@ -304,7 +317,16 @@ upsertZGoTx coll t = do app :: Pipe -> T.Text -> SecureMem -> T.Text -> IO () app pipe db passkey nodeAddress = do let run = access pipe master db - scotty 4000 $ do + scotty 3000 $ do + middleware $ + cors $ + const $ + Just + simpleCorsResourcePolicy + { corsRequestHeaders = ["Authorization", "Content-Type"] + , corsMethods = "DELETE" : simpleMethods + , corsOrigins = Nothing + } middleware $ basicAuth (\u p -> return $ u == "user" && secureMemFromByteString p == passkey) @@ -359,18 +381,18 @@ app pipe db passkey nodeAddress = do 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 "/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"] @@ -401,7 +423,8 @@ app pipe db passkey nodeAddress = do --Upsert owner to DB post "/api/owner" $ do o <- jsonData - _ <- liftIO $ run (upsertOwner o) + let q = payload (o :: Payload Owner) + _ <- liftIO $ run (upsertOwner q) status created201 --Get items associated with the given address get "/api/items" $ do @@ -554,7 +577,7 @@ scanZcash addr pipe db = do 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 . upsertZGoTx "payments") j + mapM_ (access pipe master db . upsertPayment) j -- | Function to generate users from login txs updateLogins :: T.Text -> Pipe -> T.Text -> IO () @@ -566,8 +589,60 @@ updateLogins addr pipe db = do db (rest =<< find (select ["confirmations" =: ["$lt" =: (100 :: Integer)]] "txs")) - let parsed = map parseZGoTxBson results + 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 + debug = flip trace diff --git a/src/ZGoTx.hs b/src/ZGoTx.hs index ac72399..0abbe96 100644 --- a/src/ZGoTx.hs +++ b/src/ZGoTx.hs @@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} module ZGoTx where @@ -14,7 +13,7 @@ import GHC.Generics -- | Type to model a ZGo transaction data ZGoTx = ZGoTx - { _id :: String + { _id :: Maybe ObjectId , address :: T.Text , session :: T.Text , confirmations :: Integer @@ -23,7 +22,7 @@ data ZGoTx = , txid :: T.Text , memo :: T.Text } - deriving (Eq, Show, Generic, ToJSON) + deriving (Eq, Show, Generic) parseZGoTxBson :: B.Document -> Maybe ZGoTx parseZGoTxBson d = do @@ -35,12 +34,12 @@ parseZGoTxBson d = do t <- B.lookup "txid" d m <- B.lookup "memo" d bt <- B.lookup "blocktime" d - pure $ ZGoTx (show (i :: B.ObjectId)) a s c bt am t m + pure $ ZGoTx i a s c bt am t m encodeZGoTxBson :: ZGoTx -> B.Document encodeZGoTxBson (ZGoTx i a s c bt am t m) = if not (null i) - then [ "_id" =: (read i :: B.ObjectId) + then [ "_id" =: i , "address" =: a , "session" =: s , "confirmations" =: c @@ -57,3 +56,39 @@ encodeZGoTxBson (ZGoTx i a s c bt am t m) = , "txid" =: t , "memo" =: m ] + +instance Val ZGoTx where + cast' (Doc d) = do + i <- B.lookup "_id" d + a <- B.lookup "address" d + s <- B.lookup "session" d + c <- B.lookup "confirmations" d + am <- B.lookup "amount" d + t <- B.lookup "txid" d + m <- B.lookup "memo" d + bt <- B.lookup "blocktime" d + Just (ZGoTx i a s c bt am t m) + cast' _ = Nothing + val (ZGoTx i a s c bt am t m) = + case i of + Just oid -> + Doc + [ "_id" =: i + , "address" =: a + , "session" =: s + , "confirmations" =: c + , "blocktime" =: bt + , "amount" =: am + , "txid" =: t + , "memo" =: m + ] + Nothing -> + Doc + [ "address" =: a + , "session" =: s + , "confirmations" =: c + , "blocktime" =: bt + , "amount" =: am + , "txid" =: t + , "memo" =: m + ] diff --git a/test/Spec.hs b/test/Spec.hs index 4ae1234..744e414 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -12,12 +12,16 @@ import Data.Either import Data.Maybe import Data.SecureMem import qualified Data.Text as T +import Data.Time +import Data.Time.Calendar import Data.Time.Clock import Database.MongoDB +import Item import Network.HTTP.Simple import Network.HTTP.Types.Status import Order import Owner +import Payment import System.IO.Unsafe import Test.Hspec import Test.Hspec.Expectations.Json @@ -68,7 +72,7 @@ main = "ZGO::5d3d4494-51c0-432d-8495-050419957aea\nReply-To:\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" zToZGoTx t `shouldBe` ZGoTx - "" + Nothing "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" "5d3d4494-51c0-432d-8495-050419957aea" 20 @@ -165,9 +169,15 @@ main = res <- httpLBS req getResponseStatus res `shouldBe` ok200 describe "Item endpoint" $ do - it "add item" $ do pending - it "get item" $ do pending - it "delete item" $ do pending + prop "add item" testItemAdd + it "get items" $ do + req <- testGet "/api/items" [("address", Just "Zaddy")] + res <- httpJSON req + getResponseStatus (res :: Response A.Value) `shouldBe` ok200 + it "delete item" $ do + req <- testDelete "/api/item/" "627d7ba92b05a76be3000003" + res <- httpLBS req + getResponseStatus res `shouldBe` ok200 around handleDb $ describe "Database actions" $ do describe "authentication" $ do @@ -252,17 +262,13 @@ main = _ <- scanZcash nodeAddress p "test" threadDelay 1000000 t <- access p master "test" $ findOne (select [] "payments") - case t of - Nothing -> True `shouldBe` False - Just r -> do - let s = parseZGoTxBson r - case s of - Nothing -> True `shouldBe` False - Just z -> confirmations z `shouldSatisfy` (> 0) + let s = (cast' . Doc) =<< t + let payDelta = maybe 0 pdelta s + payDelta `shouldSatisfy` (> 0) xit "login txs are converted to users" $ \p -> do let myTx = ZGoTx - "" + Nothing "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdca" 3 @@ -289,7 +295,7 @@ testGet endpoint body = do let pwd = "superSecret" let testRequest = setRequestQueryString body $ - setRequestPort 4000 $ + setRequestPort 3000 $ setRequestBasicAuth user pwd $ setRequestMethod "GET" $ setRequestPath endpoint defaultRequest return testRequest @@ -300,7 +306,7 @@ testPost endpoint body = do let pwd = "superSecret" let testRequest = setRequestQueryString body $ - setRequestPort 4000 $ + setRequestPort 3000 $ setRequestBasicAuth user pwd $ setRequestMethod "POST" $ setRequestPath endpoint defaultRequest return testRequest @@ -311,7 +317,7 @@ testPostJson endpoint body = do let pwd = "superSecret" let testRequest = setRequestBodyJSON body $ - setRequestPort 4000 $ + setRequestPort 3000 $ setRequestBasicAuth user pwd $ setRequestMethod "POST" $ setRequestPath endpoint defaultRequest return testRequest @@ -321,7 +327,7 @@ testDelete endpoint par = do let user = "user" let pwd = "superSecret" let testRequest = - setRequestPort 4000 $ + setRequestPort 3000 $ setRequestBasicAuth user pwd $ setRequestMethod "DELETE" $ setRequestPath (B.append endpoint par) defaultRequest @@ -330,7 +336,8 @@ testDelete endpoint par = do testOwnerAdd :: Owner -> Property testOwnerAdd o = monadicIO $ do - req <- run $ testPostJson "/api/owner" (A.toJSON o) --`debug` show o + req <- + run $ testPostJson "/api/owner" (A.object ["payload" A..= A.toJSON o]) --`debug` show o res <- httpLBS req assert $ getResponseStatus res == created201 @@ -341,6 +348,13 @@ testOrderAdd o = res <- httpLBS req assert $ getResponseStatus res == created201 +testItemAdd :: Item -> Property +testItemAdd i = do + monadicIO $ do + req <- run $ testPostJson "/api/item" (A.toJSON i) + res <- httpLBS req + assert $ getResponseStatus res == created201 + -- | Open the MongoDB connection openDbConnection :: IO Pipe openDbConnection = do @@ -384,6 +398,7 @@ startAPI = do , "pin" =: upin myUser , "validated" =: uvalidated myUser ]) + myTstamp <- getCurrentTime let myOwner = Owner (Just (read "627ad3492b05a76be3000001")) @@ -407,6 +422,7 @@ startAPI = do False False False + (UTCTime (fromGregorian 2022 5 16) (secondsToDiffTime 0)) _ <- access pipe master "test" (delete (select [] "owners")) let o = val myOwner case o of @@ -428,6 +444,16 @@ startAPI = do let ordTest = val myOrder case ordTest of Doc oT -> access pipe master "test" (insert_ "orders" oT) + let myItem1 = + Item + (Just (read "627d7ba92b05a76be3000003")) + "Chair" + "Made of wood" + "Zaddy" + 101.99 + let itemTest = val myItem1 + case itemTest of + Doc iT -> access pipe master "test" (insert_ "items" iT) threadDelay 1000000 putStrLn "Test server is up!" @@ -479,4 +505,14 @@ instance Arbitrary Owner where co <- arbitrary paid <- arbitrary zats <- arbitrary - Owner i a n c t tV v vV f l e s ct st p ph w co paid zats <$> arbitrary + inv <- arbitrary + exp <- arbitrary + pure $ Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv exp + +instance Arbitrary Item where + arbitrary = do + i <- arbitrary + n <- arbitrary + d <- arbitrary + o <- arbitrary + Item i n d o <$> arbitrary diff --git a/zgo-backend.cabal b/zgo-backend.cabal index ee70c97..3fa6a00 100644 --- a/zgo-backend.cabal +++ b/zgo-backend.cabal @@ -28,6 +28,7 @@ library Item Order Owner + Payment User ZGoBackend ZGoTx @@ -55,6 +56,7 @@ library , time , unordered-containers , vector + , wai-cors , wai-extra default-language: Haskell2010