diff --git a/package.yaml b/package.yaml index b998d3c..f83a955 100644 --- a/package.yaml +++ b/package.yaml @@ -91,3 +91,4 @@ tests: - mongoDB - hspec-wai - securemem + - time diff --git a/src/Order.hs b/src/Order.hs new file mode 100644 index 0000000..1def81e --- /dev/null +++ b/src/Order.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module Order where + +import Data.Aeson +import qualified Data.Bson as B +import Data.Maybe +import qualified Data.Text as T +import Data.Time.Clock +import Database.MongoDB +import GHC.Generics +import Test.QuickCheck + +-- | Type to represent a ZGo order +data ZGoOrder = + ZGoOrder + { q_id :: Maybe ObjectId + , qaddress :: T.Text + , qsession :: T.Text + , qtimestamp :: UTCTime + , qclosed :: Bool + , qcurrency :: T.Text + , qprice :: Double + , qtotal :: Double + , qtotalZec :: Double + , qlines :: [LineItem] + } + deriving (Eq, Show, Generic) + +instance ToJSON ZGoOrder where + toJSON (ZGoOrder i a s ts c cur p t tZ l) = + case i of + Just oid -> + object + [ "_id" .= show oid + , "address" .= a + , "session" .= s + , "timestamp" .= ts + , "closed" .= c + , "currency" .= cur + , "price" .= p + , "total" .= t + , "totalZec" .= tZ + , "lines" .= l + ] + Nothing -> + object + [ "_id" .= ("" :: String) + , "address" .= a + , "session" .= s + , "timestamp" .= ts + , "closed" .= c + , "currency" .= cur + , "price" .= p + , "total" .= t + , "totalZec" .= tZ + , "lines" .= l + ] + +instance FromJSON ZGoOrder where + parseJSON = + withObject "Order" $ \obj -> do + i <- obj .: "_id" + a <- obj .: "address" + s <- obj .: "session" + ts <- obj .: "timestamp" + c <- obj .: "closed" + cur <- obj .: "currency" + p <- obj .: "price" + t <- obj .: "total" + tZ <- obj .: "totalZec" + l <- obj .: "lines" + pure $ + ZGoOrder + (if not (null i) + then Just (read i) + else Nothing) + a + s + ts + c + cur + p + t + tZ + l + +instance Val ZGoOrder where + val (ZGoOrder i a s ts c cur p t tZ l) = + if isJust i + then Doc + [ "_id" =: i + , "address" =: a + , "session" =: s + , "timestamp" =: ts + , "closed" =: c + , "currency" =: cur + , "price" =: p + , "total" =: t + , "totalZec" =: tZ + , "lines" =: l + ] + else Doc + [ "address" =: a + , "session" =: s + , "timestamp" =: ts + , "closed" =: c + , "currency" =: cur + , "price" =: p + , "total" =: t + , "totalZec" =: tZ + , "lines" =: l + ] + cast' (Doc d) = do + i <- B.lookup "_id" d + a <- B.lookup "address" d + s <- B.lookup "session" d + ts <- B.lookup "timestamp" d + c <- B.lookup "closed" d + cur <- B.lookup "currency" d + p <- B.lookup "price" d + t <- B.lookup "total" d + tZ <- B.lookup "totalZec" d + l <- B.lookup "lines" d + Just (ZGoOrder i a s ts c cur p t tZ l) + cast' _ = Nothing + +-- Type to represent an order line item +data LineItem = + LineItem + { l_id :: Maybe ObjectId + , lqty :: Double + , lname :: T.Text + , lcost :: Double + } + deriving (Eq, Show) + +instance ToJSON LineItem where + toJSON (LineItem i q n c) = + case i of + Just oid -> + object ["_id" .= show oid, "qty" .= q, "name" .= n, "cost" .= c] + Nothing -> + object ["_id" .= ("" :: String), "qty" .= q, "name" .= n, "cost" .= c] + +instance FromJSON LineItem where + parseJSON = + withObject "LineItem" $ \obj -> do + i <- obj .: "_id" + q <- obj .: "qty" + n <- obj .: "name" + c <- obj .: "cost" + pure $ + LineItem + (if not (null i) + then Just (read i) + else Nothing) + q + n + c + +instance Val LineItem where + val (LineItem i q n c) = + case i of + Just oid -> Doc ["_id" =: oid, "qty" =: q, "name" =: n, "cost" =: c] + Nothing -> Doc ["qty" =: q, "name" =: n, "cost" =: c] + cast' (Doc d) = do + i <- B.lookup "_id" d + q <- B.lookup "qty" d + n <- B.lookup "name" d + c <- B.lookup "cost" d + Just (LineItem i q n c) + cast' _ = Nothing + +-- Database actions +upsertOrder :: ZGoOrder -> Action IO () +upsertOrder o = do + let order = val o + case order of + Doc d -> upsert (select ["_id" =: q_id o] "orders") d + _ -> return () + +findOrder :: T.Text -> Action IO (Maybe Document) +findOrder s = findOne (select ["session" =: s] "orders") + +findOrderById :: String -> Action IO (Maybe Document) +findOrderById i = findOne (select ["_id" =: (read i :: B.ObjectId)] "orders") + +deleteOrder :: String -> Action IO () +deleteOrder i = deleteOne (select ["_id" =: (read i :: B.ObjectId)] "orders") diff --git a/src/Owner.hs b/src/Owner.hs new file mode 100644 index 0000000..3cce76d --- /dev/null +++ b/src/Owner.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module Owner where + +import Data.Aeson +import qualified Data.Bson as B +import qualified Data.Text as T +import Data.Typeable +import Database.MongoDB +import GHC.Generics + +-- | Type to represent a ZGo shop owner/business +data Owner = + Owner + { o_id :: Maybe ObjectId + , oaddress :: T.Text + , oname :: T.Text + , ocurrency :: T.Text + , otax :: Bool + , otaxValue :: Double + , ovat :: Bool + , ovatValue :: Double + , ofirst :: T.Text + , olast :: T.Text + , oemail :: T.Text + , ostreet :: T.Text + , ocity :: T.Text + , ostate :: T.Text + , opostal :: T.Text + , ophone :: T.Text + , owebsite :: T.Text + , ocountry :: T.Text + , opaid :: Bool + , ozats :: Bool + , oinvoices :: Bool + } + 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) = + case i of + Just oid -> + object + [ "_id" .= show oid + , "address" .= a + , "name" .= n + , "currency" .= c + , "tax" .= t + , "taxValue" .= tV + , "vat" .= v + , "vatValue" .= vV + , "first" .= f + , "last" .= l + , "email" .= e + , "street" .= s + , "city" .= ct + , "state" .= st + , "postal" .= p + , "phone" .= ph + , "website" .= w + , "country" .= co + , "paid" .= paid + , "zats" .= zats + , "invoices" .= inv + ] + Nothing -> + object + [ "_id" .= ("" :: String) + , "address" .= a + , "name" .= n + , "currency" .= c + , "tax" .= t + , "taxValue" .= tV + , "vat" .= v + , "vatValue" .= vV + , "first" .= f + , "last" .= l + , "email" .= e + , "street" .= s + , "city" .= ct + , "state" .= st + , "postal" .= p + , "phone" .= ph + , "website" .= w + , "country" .= co + , "paid" .= paid + , "zats" .= zats + , "invoices" .= inv + ] + +instance FromJSON Owner where + parseJSON = + withObject "Owner" $ \obj -> do + i <- obj .: "_id" + a <- obj .: "address" + n <- obj .: "name" + c <- obj .: "currency" + t <- obj .: "tax" + tV <- obj .: "taxValue" + v <- obj .: "vat" + vV <- obj .: "vatValue" + f <- obj .: "first" + l <- obj .: "last" + e <- obj .: "email" + s <- obj .: "street" + ct <- obj .: "city" + st <- obj .: "state" + p <- obj .: "postal" + ph <- obj .: "phone" + w <- obj .: "website" + co <- obj .: "country" + paid <- obj .: "paid" + zats <- obj .: "zats" + inv <- obj .: "invoices" + pure $ + Owner + (if not (null i) + then Just (read i) + else Nothing) + a + n + c + t + tV + v + vV + f + l + e + s + ct + st + p + ph + w + co + paid + zats + inv + +instance Val Owner where + cast' (Doc d) = do + i <- B.lookup "_id" d + a <- B.lookup "address" d + n <- B.lookup "name" d + c <- B.lookup "currency" d + t <- B.lookup "tax" d + tV <- B.lookup "taxValue" d + v <- B.lookup "vat" d + vV <- B.lookup "vatValue" d + f <- B.lookup "first" d + l <- B.lookup "last" d + e <- B.lookup "email" d + s <- B.lookup "street" d + ct <- B.lookup "city" d + st <- B.lookup "state" d + p <- B.lookup "postal" d + ph <- B.lookup "phone" d + w <- B.lookup "website" d + co <- B.lookup "country" d + 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) + 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) = + case i of + Just oid -> + Doc + [ "_id" =: oid + , "address" =: a + , "name" =: n + , "currency" =: c + , "tax" =: t + , "taxValue" =: tV + , "vat" =: v + , "vatValue" =: vV + , "first" =: f + , "last" =: l + , "email" =: e + , "street" =: s + , "city" =: ct + , "state" =: st + , "postal" =: p + , "phone" =: ph + , "website" =: w + , "country" =: co + , "paid" =: paid + , "zats" =: zats + , "invoices" =: inv + ] + Nothing -> + Doc + [ "address" =: a + , "name" =: n + , "currency" =: c + , "tax" =: t + , "taxValue" =: tV + , "vat" =: v + , "vatValue" =: vV + , "first" =: f + , "last" =: l + , "email" =: e + , "street" =: s + , "city" =: ct + , "state" =: st + , "postal" =: p + , "phone" =: ph + , "website" =: w + , "country" =: co + , "paid" =: paid + , "zats" =: zats + , "invoices" =: inv + ] + +-- Database actions +-- | Function to upsert an Owner +upsertOwner :: Owner -> Action IO () +upsertOwner o = do + let owner = val o + case owner of + Doc d -> upsert (select ["address" =: oaddress o] "owners") d + _ -> return () + +-- | Function to get an Owner +findOwner :: T.Text -> Action IO (Maybe Document) +findOwner zaddy = findOne (select ["address" =: zaddy] "owners") diff --git a/src/User.hs b/src/User.hs new file mode 100644 index 0000000..fd3cb83 --- /dev/null +++ b/src/User.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module User where + +import Control.Monad +import Control.Monad.IO.Class +import Data.Aeson +import qualified Data.Bson as B +import Data.Maybe +import qualified Data.Text as T +import Database.MongoDB +import GHC.Generics +import System.IO.Unsafe +import System.Random +import ZGoTx + +-- | Type to represent a ZGo User, i.e.: a specific device +data User = + User + { u_id :: String + , uaddress :: T.Text + , usession :: T.Text + , ublocktime :: Integer + , upin :: T.Text + , uvalidated :: Bool + } + deriving (Eq, Show, Generic) + +instance ToJSON User where + toJSON (User i a s bt p v) = + object + [ "_id" .= i + , "address" .= a + , "session" .= s + , "blocktime" .= bt + , "validated" .= v + ] + +instance FromJSON User where + parseJSON = + withObject "User" $ \obj -> do + i <- obj .: "_id" + a <- obj .: "address" + s <- obj .: "session" + bt <- obj .: "blocktime" + v <- obj .: "validated" + pure $ User i a s bt "" v + +parseUserBson :: B.Document -> Maybe User +parseUserBson d = do + i <- B.lookup "_id" d + a <- B.lookup "address" d + s <- B.lookup "session" d + b <- B.lookup "blocktime" d + p <- B.lookup "pin" d + v <- B.lookup "validated" d + pure $ User (show (i :: B.ObjectId)) a s b p v + +-- Database Actions +-- | Function to query DB for unexpired user by session ID +findUser :: T.Text -> Action IO (Maybe Document) +findUser s = findOne (select ["session" =: s] "users") + +-- | Function to delete user by ID +deleteUser :: String -> Action IO () +deleteUser i = deleteOne (select ["_id" =: (read i :: B.ObjectId)] "users") + +-- | Function to verify if the given ZGoTx represents an already existing User +isUserNew :: Pipe -> T.Text -> ZGoTx -> IO Bool +isUserNew p db tx = + isNothing <$> + access p master db (findOne (select ["session" =: session tx] "users")) + +-- | Function to mark user as validated +validateUser :: T.Text -> Action IO () +validateUser session = + modify + (select ["session" =: session] "users") + ["$set" =: ["validated" =: True]] + +generatePin :: IO T.Text +generatePin = do + g <- newStdGen + pure $ + T.pack (padLeft (show . head $ randomRs (1 :: Integer, 10000000) g) '0' 7) + +-- | Helper function to pad a string to a given length +padLeft :: String -> Char -> Int -> String +padLeft s c m = + let isBaseLarger = length s > m + padder st ch m False = [ch | _ <- [1 .. (m - length st)]] ++ s + padder st _ _ True = st + in padder s c m isBaseLarger diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index a210a8e..58339f8 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -19,7 +19,9 @@ import Data.SecureMem import qualified Data.Text as T import qualified Data.Text.Lazy as L import Data.Time.Clock +import Data.Typeable import qualified Data.Vector as V +import Data.Word import Database.MongoDB import Debug.Trace import GHC.Generics @@ -27,13 +29,17 @@ import Network.HTTP.Simple import Network.HTTP.Types.Status import Network.Wai.Middleware.HttpAuth import Numeric +import Order +import Owner 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 @@ -134,8 +140,7 @@ instance Arbitrary ZcashTx where bt <- arbitrary c <- arbitrary cm <- arbitrary - m <- arbitrary - return $ ZcashTx a aZ t bh bt c cm m + ZcashTx a aZ t bh bt c cm <$> arbitrary -- | Helper function to turn a hex-encoded memo strings to readable text decodeHexText :: String -> String @@ -155,20 +160,6 @@ encodeHexText t = mconcat (map padHex t) then "0" ++ (showHex . ord) x "" else showHex (ord x) "" --- | Helper function to pad a string to a given length -padLeft :: String -> Char -> Int -> String -padLeft s c m = - let isBaseLarger = length s > m - padder s c m False = [c | _ <- [1 .. (m - length s)]] ++ s - padder s _ _ True = s - in padder s c m isBaseLarger - -generatePin :: IO T.Text -generatePin = do - g <- newStdGen - pure $ - T.pack (padLeft (show . head $ randomRs (1 :: Integer, 10000000) g) '0' 7) - -- Types for the ZGo database documents -- | Type to model a country for the database's country list data Country = @@ -186,95 +177,6 @@ parseCountryBson d = do c <- B.lookup "code" d pure $ Country (show (i :: B.ObjectId)) n c --- | Type to represent a ZGo User, i.e.: a specific device -data User = - User - { u_id :: String - , uaddress :: T.Text - , usession :: T.Text - , ublocktime :: Integer - , upin :: T.Text - , uvalidated :: Bool - } - deriving (Eq, Show, Generic) - -instance ToJSON User where - toJSON (User i a s bt p v) = - object - [ "_id" .= i - , "address" .= a - , "session" .= s - , "blocktime" .= bt - , "validated" .= v - ] - -instance FromJSON User where - parseJSON = - withObject "User" $ \obj -> do - i <- obj .: "_id" - a <- obj .: "address" - s <- obj .: "session" - bt <- obj .: "blocktime" - v <- obj .: "validated" - pure $ User i a s bt "" v - -parseUserBson :: B.Document -> Maybe User -parseUserBson d = do - i <- B.lookup "_id" d - a <- B.lookup "address" d - s <- B.lookup "session" d - b <- B.lookup "blocktime" d - p <- B.lookup "pin" d - v <- B.lookup "validated" d - pure $ User (show (i :: B.ObjectId)) a s b p v - --- | Type to model a ZGo transaction -data ZGoTx = - ZGoTx - { _id :: String - , address :: T.Text - , session :: T.Text - , confirmations :: Integer - , blocktime :: Integer - , amount :: Double - , txid :: T.Text - , memo :: T.Text - } - deriving (Eq, Show, Generic, ToJSON) - -parseZGoTxBson :: B.Document -> Maybe ZGoTx -parseZGoTxBson 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 - pure $ ZGoTx (show (i :: B.ObjectId)) 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" =: i - , "address" =: a - , "session" =: s - , "confirmations" =: c - , "blocktime" =: bt - , "amount" =: am - , "txid" =: t - , "memo" =: m - ] - else [ "address" =: a - , "session" =: s - , "confirmations" =: c - , "blocktime" =: bt - , "amount" =: am - , "txid" =: t - , "memo" =: m - ] - zToZGoTx :: ZcashTx -> ZGoTx zToZGoTx (ZcashTx t a aZ bh bt c conf m) = do let r = @@ -287,14 +189,14 @@ zToZGoTx (ZcashTx t a aZ bh bt c conf m) = do let reg2 = matchAllText p (T.unpack m) if not (null reg) then do - let session = T.pack (fst $ head reg ! 1) + let sess = T.pack (fst $ head reg ! 1) let addy = T.pack (fst $ head reg ! 2) - ZGoTx "" addy session conf bt a t m + ZGoTx "" addy sess conf bt a t m else do if not (null reg2) then do - let session = T.pack (fst $ head reg2 ! 1) - ZGoTx "" "" session conf bt a t m + let sess = T.pack (fst $ head reg2 ! 1) + ZGoTx "" "" sess conf bt a t m else ZGoTx "" "" "" conf bt a t m -- |Type to model a price in the ZGo database @@ -331,44 +233,6 @@ instance FromJSON CoinGeckoPrices where listCountries :: Action IO [Document] listCountries = rest =<< find (select [] "countries") --- | Function to query DB for unexpired user by session ID -findUser :: T.Text -> Action IO (Maybe Document) -findUser s = findOne (select ["session" =: s] "users") - --- | 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 delete user by ID -deleteUser :: String -> Action IO () -deleteUser i = deleteOne (select ["_id" =: (read i :: B.ObjectId)] "users") - --- | Function to verify if the given ZGoTx represents an already existing User -isUserNew :: Pipe -> T.Text -> ZGoTx -> IO Bool -isUserNew p db tx = - isNothing <$> - access p master db (findOne (select ["session" =: session tx] "users")) - --- | Function to mark user as validated -validateUser :: T.Text -> Action IO () -validateUser session = - modify - (select ["session" =: session] "users") - ["$set" =: ["validated" =: True]] - sendPin :: T.Text -> T.Text -> T.Text -> Action IO String sendPin nodeAddress addr pin = do let payload = @@ -388,6 +252,23 @@ sendPin nodeAddress addr pin = do 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 = @@ -441,8 +322,8 @@ app pipe db passkey nodeAddress = do ]) --Get user associated with session get "/api/user" $ do - session <- param "session" - user <- liftIO $ run (findUser session) + sess <- param "session" + user <- liftIO $ run (findUser sess) case user of Nothing -> status noContent204 Just u -> @@ -454,21 +335,23 @@ app pipe db passkey nodeAddress = do --Validate user, updating record post "/api/validateuser" $ do providedPin <- param "pin" - session <- param "session" - user <- liftIO $ run (findUser session) + sess <- param "session" + user <- liftIO $ run (findUser sess) case user of - Nothing -> status noContent204 + Nothing -> status noContent204 --`debug` "No user match" Just u -> do let parsedUser = parseUserBson u case parsedUser of - Nothing -> status noContent204 + Nothing -> status noContent204 --`debug` "Couldn't parse user" Just pUser -> do - let result = upin pUser == providedPin - if result + let ans = upin pUser == T.pack providedPin + if ans then do - liftIO $ run (validateUser session) + liftIO $ run (validateUser sess) status accepted202 - else status noContent204 + 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" @@ -476,8 +359,8 @@ app pipe db passkey nodeAddress = do status ok200 --Get txs from DB that have less than 10 confirmations get "/api/pending" $ do - session <- param "session" - pending <- liftIO $ run (findPending session) + sess <- param "session" + pending <- liftIO $ run (findPending sess) case pending of [] -> do status noContent204 @@ -498,9 +381,27 @@ app pipe db passkey nodeAddress = do --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 text "Here's an owner for you" + 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 text "I added an owner for you" + post "/api/owner" $ do + o <- jsonData + _ <- liftIO $ run (upsertOwner o) + status created201 --Get items associated with the given address get "/api/items" $ do text "Here are your items" --Upsert item @@ -509,9 +410,9 @@ app pipe db passkey nodeAddress = do Web.Scotty.delete "/api/item/:id" $ do text "Deleted that pesky item" --Get price for Zcash get "/api/price" $ do - currency <- param "currency" - price <- liftIO $ run (findPrice currency) - case price of + curr <- param "currency" + pr <- liftIO $ run (findPrice curr) + case pr of Nothing -> do status noContent204 --Web.Scotty.json (object ["message" .= ("No price" :: T.Text)]) @@ -526,13 +427,47 @@ app pipe db passkey nodeAddress = do --Get order by id for receipts get "/api/order/:id" $ do oId <- param "id" - text (L.pack ("Here's the order" <> oId)) + 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 - diff <- param "diff" - text (L.pack ("This is a diff order" <> diff)) + 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 text "Upserted your order" + post "/api/order" $ do + newOrder <- jsonData + _ <- liftIO $ run (upsertOrder newOrder) + 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 :: @@ -575,10 +510,10 @@ checkZcashPrices p db = do -- | 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] + res <- makeZcashCall "z_listreceivedbyaddress" [Data.Aeson.String addr] let txs = filter (not . zchange) $ - result (getResponseBody r :: RpcResponse [ZcashTx]) + 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}).*" diff --git a/src/ZGoTx.hs b/src/ZGoTx.hs new file mode 100644 index 0000000..ac72399 --- /dev/null +++ b/src/ZGoTx.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module ZGoTx where + +import Data.Aeson +import qualified Data.Bson as B +import qualified Data.Text as T +import Database.MongoDB +import GHC.Generics + +-- | Type to model a ZGo transaction +data ZGoTx = + ZGoTx + { _id :: String + , address :: T.Text + , session :: T.Text + , confirmations :: Integer + , blocktime :: Integer + , amount :: Double + , txid :: T.Text + , memo :: T.Text + } + deriving (Eq, Show, Generic, ToJSON) + +parseZGoTxBson :: B.Document -> Maybe ZGoTx +parseZGoTxBson 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 + pure $ ZGoTx (show (i :: B.ObjectId)) 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) + , "address" =: a + , "session" =: s + , "confirmations" =: c + , "blocktime" =: bt + , "amount" =: am + , "txid" =: t + , "memo" =: m + ] + else [ "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 afd418c..9a40eb2 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -12,16 +12,22 @@ import Data.Either import Data.Maybe import Data.SecureMem import qualified Data.Text as T +import Data.Time.Clock import Database.MongoDB import Network.HTTP.Simple import Network.HTTP.Types.Status +import Order +import Owner import System.IO.Unsafe import Test.Hspec import Test.Hspec.Expectations.Json import Test.Hspec.QuickCheck import Test.QuickCheck import Test.QuickCheck.Gen +import Test.QuickCheck.Monadic +import User import ZGoBackend +import ZGoTx passkey :: SecureMem passkey = secureMemFromByteString "superSecret" @@ -102,7 +108,7 @@ main = req <- testGet "/api/user" - [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdca")] + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] res <- httpJSON req getResponseStatus (res :: Response A.Value) `shouldBe` ok200 it "returns 204 when no user" $ do @@ -115,9 +121,9 @@ main = it "validate with correct pin" $ do req <- testPost - "/api/validateuser/" - [ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdca") - , ("pin", Just "5989845") + "/api/validateuser" + [ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd") + , ("pin", Just "1234567") ] res <- httpLBS req getResponseStatus res `shouldBe` accepted202 @@ -126,13 +132,35 @@ main = res <- httpLBS req getResponseStatus res `shouldBe` ok200 describe "Owner endpoint" $ do - it "add owner" $ do pending - it "return owner" $ do pending + prop "add owner" testOwnerAdd + it "return owner" $ do + req <- + testGet + "/api/owner" + [ ( "address" + , Just + "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e") + ] + res <- httpJSON req + getResponseStatus (res :: Response A.Value) `shouldBe` ok200 describe "Order endpoint" $ do - it "upsert order" $ do pending - it "get order by session" $ do pending - it "get order by id" $ do pending + prop "upsert order" testOrderAdd + it "get order by session" $ do + req <- + testGet + "/api/order" + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + res <- httpJSON req + getResponseStatus (res :: Response A.Value) `shouldBe` ok200 + it "get order by id" $ do + req <- testGet "/api/order/627ab3ea2b05a76be3000000" [] + res <- httpJSON req + getResponseStatus (res :: Response A.Value) `shouldBe` ok200 it "get all orders for owner" $ do pending + it "delete order by id" $ do + req <- testDelete "/api/order/" "627ab3ea2b05a76be3000000" + res <- httpLBS req + getResponseStatus res `shouldBe` ok200 around handleDb $ describe "Database actions" $ do describe "authentication" $ do @@ -164,6 +192,41 @@ main = Just r2 -> do let t2 = ZGoBackend.timestamp r2 t2 `shouldSatisfy` (t1 <) + describe "user is" $ do + it "validated" $ \p -> do + t <- + access p master "test" $ + findOne (select ["validated" =: False] "users") + case t of + Nothing -> True `shouldBe` False + Just r -> do + let s = parseUserBson r + case s of + Nothing -> True `shouldBe` False + Just z -> do + _ <- access p master "test" $ validateUser (usession z) + q <- + access p master "test" $ + findOne + (select + ["validated" =: True, "session" =: usession z] + "users") + isNothing q `shouldBe` False + it "deleted" $ \p -> do + 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 -> do + _ <- access p master "test" $ deleteUser (u_id z) + q <- + access p master "test" $ + findOne + (select ["_id" =: (read (u_id z) :: ObjectId)] "users") + isNothing q `shouldBe` True describe "Zcash transactions" $ do it "logins are added to db" $ \p -> do _ <- access p master "test" (delete (select [] "txs")) @@ -212,41 +275,6 @@ main = case s of Nothing -> True `shouldBe` False Just z -> length (T.unpack (usession z)) `shouldSatisfy` (> 0) - describe "user is" $ do - it "validated" $ \p -> do - t <- - access p master "test" $ - findOne (select ["validated" =: False] "users") - case t of - Nothing -> True `shouldBe` False - Just r -> do - let s = parseUserBson r - case s of - Nothing -> True `shouldBe` False - Just z -> do - _ <- access p master "test" $ validateUser (usession z) - q <- - access p master "test" $ - findOne - (select - ["validated" =: True, "session" =: usession z] - "users") - isNothing q `shouldBe` False - it "deleted" $ \p -> do - 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 -> do - _ <- access p master "test" $ deleteUser (u_id z) - q <- - access p master "test" $ - findOne - (select ["_id" =: (read (u_id z) :: ObjectId)] "users") - isNothing q `shouldBe` True testGet :: B.ByteString -> [(B.ByteString, Maybe B.ByteString)] -> IO Request testGet endpoint body = do @@ -270,6 +298,17 @@ testPost endpoint body = do setRequestMethod "POST" $ setRequestPath endpoint defaultRequest return testRequest +testPostJson :: B.ByteString -> A.Value -> IO Request +testPostJson endpoint body = do + let user = "user" + let pwd = "superSecret" + let testRequest = + setRequestBodyJSON body $ + setRequestPort 4000 $ + setRequestBasicAuth user pwd $ + setRequestMethod "POST" $ setRequestPath endpoint defaultRequest + return testRequest + testDelete :: B.ByteString -> B.ByteString -> IO Request testDelete endpoint par = do let user = "user" @@ -281,6 +320,20 @@ testDelete endpoint par = do setRequestPath (B.append endpoint par) defaultRequest return testRequest +testOwnerAdd :: Owner -> Property +testOwnerAdd o = + monadicIO $ do + req <- run $ testPostJson "/api/owner" (A.toJSON o) --`debug` show o + res <- httpLBS req + assert $ getResponseStatus res == created201 + +testOrderAdd :: ZGoOrder -> Property +testOrderAdd o = + monadicIO $ do + req <- run $ testPostJson "/api/order" (A.toJSON o) + res <- httpLBS req + assert $ getResponseStatus res == created201 + -- | Open the MongoDB connection openDbConnection :: IO Pipe openDbConnection = do @@ -302,5 +355,121 @@ startAPI = do pipe <- connect $ host "127.0.0.1" c <- access pipe master "zgo" (auth "zgo" "zcashrules") _ <- forkIO (app pipe "test" passkey nodeAddress) + let myUser = + User + "6272a90f2b05a74cf1000001" + "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd" + 1613487 + "1234567" + False + _ <- + access + pipe + master + "test" + (insert_ + "users" + [ "address" =: uaddress myUser + , "_id" =: (read (u_id myUser) :: ObjectId) + , "session" =: usession myUser + , "blocktime" =: ublocktime myUser + , "pin" =: upin myUser + , "validated" =: uvalidated myUser + ]) + let myOwner = + Owner + (Just (read "627ad3492b05a76be3000001")) + "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "Test shop" + "usd" + False + 0 + False + 0 + "Bubba" + "Gibou" + "bubba@zgo.cash" + "1 Main St" + "Mpls" + "Minnesota" + "55401" + "" + "bubbarocks.io" + "United States" + False + False + False + _ <- access pipe master "test" (delete (select [] "owners")) + let o = val myOwner + case o of + Doc d -> access pipe master "test" (insert_ "owners" d) + _ <- access pipe master "test" (delete (select [] "orders")) + myTs <- liftIO getCurrentTime + let myOrder = + ZGoOrder + (Just (read "627ab3ea2b05a76be3000000")) + "Zaddy" + "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd" + myTs + False + "usd" + 102.0 + 0 + 0 + [] + let ordTest = val myOrder + case ordTest of + Doc oT -> access pipe master "test" (insert_ "orders" oT) threadDelay 1000000 putStrLn "Test server is up!" + +--QuickCheck instances +instance Arbitrary ZGoOrder where + arbitrary = do + i <- arbitrary + a <- arbitrary + s <- arbitrary + ts <- arbitrary + c <- arbitrary + cur <- arbitrary + p <- arbitrary + t <- arbitrary + tZ <- arbitrary + ZGoOrder i a s ts c cur p t tZ <$> arbitrary + +instance Arbitrary LineItem where + arbitrary = do + i <- arbitrary + q <- arbitrary + n <- arbitrary + LineItem i q n <$> arbitrary + +instance Arbitrary ObjectId where + arbitrary = do + x <- arbitrary + Oid x <$> arbitrary + +instance Arbitrary Owner where + arbitrary = do + i <- arbitrary + a <- arbitrary + n <- arbitrary + c <- arbitrary + t <- arbitrary + tV <- arbitrary + v <- arbitrary + vV <- arbitrary + f <- arbitrary + l <- arbitrary + e <- arbitrary + s <- arbitrary + ct <- arbitrary + st <- arbitrary + p <- arbitrary + ph <- arbitrary + w <- arbitrary + 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 diff --git a/zgo-backend.cabal b/zgo-backend.cabal index 9346a5a..3232ebb 100644 --- a/zgo-backend.cabal +++ b/zgo-backend.cabal @@ -25,7 +25,11 @@ source-repository head library exposed-modules: + Order + Owner + User ZGoBackend + ZGoTx other-modules: Paths_zgo_backend hs-source-dirs: @@ -96,5 +100,6 @@ test-suite zgo-backend-test , mongoDB , securemem , text + , time , zgo-backend default-language: Haskell2010