Refactor code

This commit is contained in:
Rene Vergara 2022-05-11 15:04:46 -05:00
parent a0e24d9742
commit df530a9fd2
Signed by: pitmutt
GPG Key ID: 65122AD495A7F5B2
8 changed files with 899 additions and 214 deletions

View File

@ -91,3 +91,4 @@ tests:
- mongoDB - mongoDB
- hspec-wai - hspec-wai
- securemem - securemem
- time

192
src/Order.hs Normal file
View File

@ -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")

229
src/Owner.hs Normal file
View File

@ -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")

95
src/User.hs Normal file
View File

@ -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

View File

@ -19,7 +19,9 @@ import Data.SecureMem
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy as L
import Data.Time.Clock import Data.Time.Clock
import Data.Typeable
import qualified Data.Vector as V import qualified Data.Vector as V
import Data.Word
import Database.MongoDB import Database.MongoDB
import Debug.Trace import Debug.Trace
import GHC.Generics import GHC.Generics
@ -27,13 +29,17 @@ import Network.HTTP.Simple
import Network.HTTP.Types.Status import Network.HTTP.Types.Status
import Network.Wai.Middleware.HttpAuth import Network.Wai.Middleware.HttpAuth
import Numeric import Numeric
import Order
import Owner
import System.IO.Unsafe import System.IO.Unsafe
import System.Random import System.Random
import Test.QuickCheck import Test.QuickCheck
import Test.QuickCheck.Instances import Test.QuickCheck.Instances
import Text.Regex import Text.Regex
import Text.Regex.Base import Text.Regex.Base
import User
import Web.Scotty import Web.Scotty
import ZGoTx
-- Models for API objects -- Models for API objects
-- | A type to model Zcash RPC calls -- | A type to model Zcash RPC calls
@ -134,8 +140,7 @@ instance Arbitrary ZcashTx where
bt <- arbitrary bt <- arbitrary
c <- arbitrary c <- arbitrary
cm <- arbitrary cm <- arbitrary
m <- arbitrary ZcashTx a aZ t bh bt c cm <$> arbitrary
return $ ZcashTx a aZ t bh bt c cm m
-- | Helper function to turn a hex-encoded memo strings to readable text -- | Helper function to turn a hex-encoded memo strings to readable text
decodeHexText :: String -> String decodeHexText :: String -> String
@ -155,20 +160,6 @@ encodeHexText t = mconcat (map padHex t)
then "0" ++ (showHex . ord) x "" then "0" ++ (showHex . ord) x ""
else 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 -- Types for the ZGo database documents
-- | Type to model a country for the database's country list -- | Type to model a country for the database's country list
data Country = data Country =
@ -186,95 +177,6 @@ parseCountryBson d = do
c <- B.lookup "code" d c <- B.lookup "code" d
pure $ Country (show (i :: B.ObjectId)) n c 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 -> ZGoTx
zToZGoTx (ZcashTx t a aZ bh bt c conf m) = do zToZGoTx (ZcashTx t a aZ bh bt c conf m) = do
let r = let r =
@ -287,14 +189,14 @@ zToZGoTx (ZcashTx t a aZ bh bt c conf m) = do
let reg2 = matchAllText p (T.unpack m) let reg2 = matchAllText p (T.unpack m)
if not (null reg) if not (null reg)
then do 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) 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 else do
if not (null reg2) if not (null reg2)
then do then do
let session = T.pack (fst $ head reg2 ! 1) let sess = T.pack (fst $ head reg2 ! 1)
ZGoTx "" "" session conf bt a t m ZGoTx "" "" sess conf bt a t m
else ZGoTx "" "" "" conf bt a t m else ZGoTx "" "" "" conf bt a t m
-- |Type to model a price in the ZGo database -- |Type to model a price in the ZGo database
@ -331,44 +233,6 @@ instance FromJSON CoinGeckoPrices where
listCountries :: Action IO [Document] listCountries :: Action IO [Document]
listCountries = rest =<< find (select [] "countries") 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 :: T.Text -> T.Text -> T.Text -> Action IO String
sendPin nodeAddress addr pin = do sendPin nodeAddress addr pin = do
let payload = let payload =
@ -388,6 +252,23 @@ sendPin nodeAddress addr pin = do
then return "Pin sent!" then return "Pin sent!"
else return "Pin sending failed :(" 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 -- | Function to query DB for transactions with less than 10 confirmations
findPending :: String -> Action IO [Document] findPending :: String -> Action IO [Document]
findPending s = findPending s =
@ -441,8 +322,8 @@ app pipe db passkey nodeAddress = do
]) ])
--Get user associated with session --Get user associated with session
get "/api/user" $ do get "/api/user" $ do
session <- param "session" sess <- param "session"
user <- liftIO $ run (findUser session) user <- liftIO $ run (findUser sess)
case user of case user of
Nothing -> status noContent204 Nothing -> status noContent204
Just u -> Just u ->
@ -454,21 +335,23 @@ app pipe db passkey nodeAddress = do
--Validate user, updating record --Validate user, updating record
post "/api/validateuser" $ do post "/api/validateuser" $ do
providedPin <- param "pin" providedPin <- param "pin"
session <- param "session" sess <- param "session"
user <- liftIO $ run (findUser session) user <- liftIO $ run (findUser sess)
case user of case user of
Nothing -> status noContent204 Nothing -> status noContent204 --`debug` "No user match"
Just u -> do Just u -> do
let parsedUser = parseUserBson u let parsedUser = parseUserBson u
case parsedUser of case parsedUser of
Nothing -> status noContent204 Nothing -> status noContent204 --`debug` "Couldn't parse user"
Just pUser -> do Just pUser -> do
let result = upin pUser == providedPin let ans = upin pUser == T.pack providedPin
if result if ans
then do then do
liftIO $ run (validateUser session) liftIO $ run (validateUser sess)
status accepted202 status accepted202
else status noContent204 else status noContent204 `debug`
("Pins didn't match: " ++
providedPin ++ " " ++ T.unpack (upin pUser))
--Delete user --Delete user
Web.Scotty.delete "/api/user/:id" $ do Web.Scotty.delete "/api/user/:id" $ do
userId <- param "id" userId <- param "id"
@ -476,8 +359,8 @@ app pipe db passkey nodeAddress = do
status ok200 status ok200
--Get txs from DB that have less than 10 confirmations --Get txs from DB that have less than 10 confirmations
get "/api/pending" $ do get "/api/pending" $ do
session <- param "session" sess <- param "session"
pending <- liftIO $ run (findPending session) pending <- liftIO $ run (findPending sess)
case pending of case pending of
[] -> do [] -> do
status noContent204 status noContent204
@ -498,9 +381,27 @@ app pipe db passkey nodeAddress = do
--Get the ZGo node's shielded address --Get the ZGo node's shielded address
get "/api/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress]) get "/api/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress])
--Get owner by address --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 --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 items associated with the given address
get "/api/items" $ do text "Here are your items" get "/api/items" $ do text "Here are your items"
--Upsert item --Upsert item
@ -509,9 +410,9 @@ app pipe db passkey nodeAddress = do
Web.Scotty.delete "/api/item/:id" $ do text "Deleted that pesky item" Web.Scotty.delete "/api/item/:id" $ do text "Deleted that pesky item"
--Get price for Zcash --Get price for Zcash
get "/api/price" $ do get "/api/price" $ do
currency <- param "currency" curr <- param "currency"
price <- liftIO $ run (findPrice currency) pr <- liftIO $ run (findPrice curr)
case price of case pr of
Nothing -> do Nothing -> do
status noContent204 status noContent204
--Web.Scotty.json (object ["message" .= ("No price" :: T.Text)]) --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 order by id for receipts
get "/api/order/:id" $ do get "/api/order/:id" $ do
oId <- param "id" 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 order by session
get "/api/order" $ do get "/api/order" $ do
diff <- param "diff" sess <- param "session"
text (L.pack ("This is a diff order" <> diff)) 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 --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 -- |Make a Zcash RPC call
makeZcashCall :: makeZcashCall ::
@ -575,10 +510,10 @@ checkZcashPrices p db = do
-- | Function to check the ZGo full node for new txs -- | Function to check the ZGo full node for new txs
scanZcash :: T.Text -> Pipe -> T.Text -> IO () scanZcash :: T.Text -> Pipe -> T.Text -> IO ()
scanZcash addr pipe db = do scanZcash addr pipe db = do
r <- makeZcashCall "z_listreceivedbyaddress" [Data.Aeson.String addr] res <- makeZcashCall "z_listreceivedbyaddress" [Data.Aeson.String addr]
let txs = let txs =
filter (not . zchange) $ filter (not . zchange) $
result (getResponseBody r :: RpcResponse [ZcashTx]) result (getResponseBody res :: RpcResponse [ZcashTx])
let r = let r =
mkRegex 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}).*" ".*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}).*"

59
src/ZGoTx.hs Normal file
View File

@ -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
]

View File

@ -12,16 +12,22 @@ import Data.Either
import Data.Maybe import Data.Maybe
import Data.SecureMem import Data.SecureMem
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time.Clock
import Database.MongoDB import Database.MongoDB
import Network.HTTP.Simple import Network.HTTP.Simple
import Network.HTTP.Types.Status import Network.HTTP.Types.Status
import Order
import Owner
import System.IO.Unsafe import System.IO.Unsafe
import Test.Hspec import Test.Hspec
import Test.Hspec.Expectations.Json import Test.Hspec.Expectations.Json
import Test.Hspec.QuickCheck import Test.Hspec.QuickCheck
import Test.QuickCheck import Test.QuickCheck
import Test.QuickCheck.Gen import Test.QuickCheck.Gen
import Test.QuickCheck.Monadic
import User
import ZGoBackend import ZGoBackend
import ZGoTx
passkey :: SecureMem passkey :: SecureMem
passkey = secureMemFromByteString "superSecret" passkey = secureMemFromByteString "superSecret"
@ -102,7 +108,7 @@ main =
req <- req <-
testGet testGet
"/api/user" "/api/user"
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdca")] [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
res <- httpJSON req res <- httpJSON req
getResponseStatus (res :: Response A.Value) `shouldBe` ok200 getResponseStatus (res :: Response A.Value) `shouldBe` ok200
it "returns 204 when no user" $ do it "returns 204 when no user" $ do
@ -115,9 +121,9 @@ main =
it "validate with correct pin" $ do it "validate with correct pin" $ do
req <- req <-
testPost testPost
"/api/validateuser/" "/api/validateuser"
[ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdca") [ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
, ("pin", Just "5989845") , ("pin", Just "1234567")
] ]
res <- httpLBS req res <- httpLBS req
getResponseStatus res `shouldBe` accepted202 getResponseStatus res `shouldBe` accepted202
@ -126,13 +132,35 @@ main =
res <- httpLBS req res <- httpLBS req
getResponseStatus res `shouldBe` ok200 getResponseStatus res `shouldBe` ok200
describe "Owner endpoint" $ do describe "Owner endpoint" $ do
it "add owner" $ do pending prop "add owner" testOwnerAdd
it "return owner" $ do pending 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 describe "Order endpoint" $ do
it "upsert order" $ do pending prop "upsert order" testOrderAdd
it "get order by session" $ do pending it "get order by session" $ do
it "get order by id" $ do pending 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 "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 $ around handleDb $
describe "Database actions" $ do describe "Database actions" $ do
describe "authentication" $ do describe "authentication" $ do
@ -164,6 +192,41 @@ main =
Just r2 -> do Just r2 -> do
let t2 = ZGoBackend.timestamp r2 let t2 = ZGoBackend.timestamp r2
t2 `shouldSatisfy` (t1 <) 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 describe "Zcash transactions" $ do
it "logins are added to db" $ \p -> do it "logins are added to db" $ \p -> do
_ <- access p master "test" (delete (select [] "txs")) _ <- access p master "test" (delete (select [] "txs"))
@ -212,41 +275,6 @@ main =
case s of case s of
Nothing -> True `shouldBe` False Nothing -> True `shouldBe` False
Just z -> length (T.unpack (usession z)) `shouldSatisfy` (> 0) 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 :: B.ByteString -> [(B.ByteString, Maybe B.ByteString)] -> IO Request
testGet endpoint body = do testGet endpoint body = do
@ -270,6 +298,17 @@ testPost endpoint body = do
setRequestMethod "POST" $ setRequestPath endpoint defaultRequest setRequestMethod "POST" $ setRequestPath endpoint defaultRequest
return testRequest 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 :: B.ByteString -> B.ByteString -> IO Request
testDelete endpoint par = do testDelete endpoint par = do
let user = "user" let user = "user"
@ -281,6 +320,20 @@ testDelete endpoint par = do
setRequestPath (B.append endpoint par) defaultRequest setRequestPath (B.append endpoint par) defaultRequest
return testRequest 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 -- | Open the MongoDB connection
openDbConnection :: IO Pipe openDbConnection :: IO Pipe
openDbConnection = do openDbConnection = do
@ -302,5 +355,121 @@ startAPI = do
pipe <- connect $ host "127.0.0.1" pipe <- connect $ host "127.0.0.1"
c <- access pipe master "zgo" (auth "zgo" "zcashrules") c <- access pipe master "zgo" (auth "zgo" "zcashrules")
_ <- forkIO (app pipe "test" passkey nodeAddress) _ <- 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 threadDelay 1000000
putStrLn "Test server is up!" 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

View File

@ -25,7 +25,11 @@ source-repository head
library library
exposed-modules: exposed-modules:
Order
Owner
User
ZGoBackend ZGoBackend
ZGoTx
other-modules: other-modules:
Paths_zgo_backend Paths_zgo_backend
hs-source-dirs: hs-source-dirs:
@ -96,5 +100,6 @@ test-suite zgo-backend-test
, mongoDB , mongoDB
, securemem , securemem
, text , text
, time
, zgo-backend , zgo-backend
default-language: Haskell2010 default-language: Haskell2010