Vergara_Tech/zgo-backend
Vergara_Tech
/
zgo-backend
2
1
Fork 0
Code Issues Pull Requests Packages Projects Releases 4 Wiki Activity

Merge branch 'security1'

This commit is contained in:
Rene Vergara 2023-06-26 11:28:33 -05:00
parent a8d4329e7d 9376d959f8
commit ea731df20d
Signed by: pitmutt
GPG Key ID: 65122AD495A7F5B2
18 changed files with 1295 additions and 426 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
CHANGELOG.md
View File

@ -4,7 +4,39 @@ All notable changes to this project will be documented in this file.
The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),
and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html).
## [1.5.0]
## [1.7.0]
### Added
- Parameter to config for number of confirmations for scan
- Endpoint for language for invoices
### Changed
- Modified payment confirmation to use new WooCommerce plugin API endpoint.
- Consolidated the `invdata`, `orderid` and `orderx` endpoints
- The `xerotoken` endpoint uses `session` for authentication
- The order by ID/token endpoint includes shop name
### Fixed
- The viewing key obfuscation of blank viewing keys
## [1.6.0]
### Added
- New JSON serialization for WooTokens.
- New `/api/ownervk` endpoint to save viewing keys
- Use of `zcash-haskell` library to validate Sapling viewing keys
### Changed
- Modified the process of scanning for payments to only scan addresses that have an active ZGo session and have enabled payment confirmations
- Modified the process to mark paid orders to ensure only payments to the shop's wallet get marked as paid
- Modified the `items` endpoint to use the login session to identify records
## [1.5.0] - 2023-05-15
### Added

3
README.md
View File

@ -6,7 +6,8 @@ The API server behind the [ZGo.cash](https://zgo.cash) app.
## Dependencies
- Zcash Full node
- Zcash Full node (`zcashd`)
- [Zcash Haskell](https://git.vergara.tech/Vergara_Tech/zcash-haskell)
- MongoDB
## Configuration

6
package.yaml
View File

@ -1,5 +1,5 @@
name: zgo-backend
version: 1.5.0
version: 1.7.0
git: "https://git.vergara.tech/Vergara_Tech/zgo-backend"
license: BOSL
author: "Rene Vergara"
@ -62,6 +62,7 @@ library:
- crypto-rng
- megaparsec
- uuid
- zcash-haskell
executables:
zgo-backend-exe:
@ -161,3 +162,6 @@ tests:
- time
- configurator
- scotty
- megaparsec
- uuid
- zcash-haskell

3
src/Config.hs
View File

@ -26,6 +26,7 @@ data Config =
, c_smtpPort :: Integer
, c_smtpUser :: String
, c_smtpPwd :: String
, c_confirmations :: Integer
}
deriving (Eq, Show)
@ -48,6 +49,7 @@ loadZGoConfig path = do
mailPort <- require config "smtpPort"
mailUser <- require config "smtpUser"
mailPwd <- require config "smtpPwd"
conf <- require config "confirmations"
return $
Config
dbHost
@ -66,3 +68,4 @@ loadZGoConfig path = do
mailPort
mailUser
mailPwd
conf

4
src/Item.hs
View File

@ -12,6 +12,7 @@ import Data.Time.Clock
import Database.MongoDB
import GHC.Generics
import Test.QuickCheck
import User
-- | Type to represent a ZGo item
data Item =
@ -87,6 +88,9 @@ findItems :: T.Text -> Action IO [Document]
findItems a =
rest =<< find (select ["owner" =: a] "items") {sort = ["name" =: (1 :: Int)]}
findItemById :: String -> Action IO (Maybe Document)
findItemById i = findOne (select ["_id" =: (read i :: ObjectId)] "items")
upsertItem :: Item -> Action IO ()
upsertItem i = do
let item = val i

19
src/Order.hs
View File

@ -29,11 +29,12 @@ data ZGoOrder =
, qpaid :: Bool
, qexternalInvoice :: T.Text
, qshortCode :: T.Text
, qtoken :: T.Text
}
deriving (Eq, Show, Generic)
instance ToJSON ZGoOrder where
toJSON (ZGoOrder i a s ts c cur p t tZ l paid eI sC) =
toJSON (ZGoOrder i a s ts c cur p t tZ l paid eI sC tk) =
case i of
Just oid ->
object
@ -50,6 +51,7 @@ instance ToJSON ZGoOrder where
, "paid" .= paid
, "externalInvoice" .= eI
, "shortCode" .= sC
, "token" .= tk
]
Nothing ->
object
@ -66,6 +68,7 @@ instance ToJSON ZGoOrder where
, "paid" .= paid
, "externalInvoice" .= eI
, "shortCode" .= sC
, "token" .= tk
]
instance FromJSON ZGoOrder where
@ -84,6 +87,7 @@ instance FromJSON ZGoOrder where
pd <- obj .: "paid"
eI <- obj .: "externalInvoice"
sC <- obj .: "shortCode"
tk <- obj .: "token"
pure $
ZGoOrder
(if not (null i)
@ -101,9 +105,10 @@ instance FromJSON ZGoOrder where
pd
eI
sC
tk
instance Val ZGoOrder where
val (ZGoOrder i a s ts c cur p t tZ l pd eI sC) =
val (ZGoOrder i a s ts c cur p t tZ l pd eI sC tk) =
if isJust i
then Doc
[ "_id" =: i
@ -119,6 +124,7 @@ instance Val ZGoOrder where
, "paid" =: pd
, "externalInvoice" =: eI
, "shortCode" =: sC
, "token" =: tk
]
else Doc
[ "address" =: a
@ -133,6 +139,7 @@ instance Val ZGoOrder where
, "paid" =: pd
, "externalInvoice" =: eI
, "shortCode" =: sC
, "token" =: tk
]
cast' (Doc d) = do
i <- B.lookup "_id" d
@ -148,7 +155,8 @@ instance Val ZGoOrder where
pd <- B.lookup "paid" d
eI <- B.lookup "externalInvoice" d
sC <- B.lookup "shortCode" d
Just (ZGoOrder i a s ts c cur p t tZ l pd eI sC)
tk <- B.lookup "token" d
Just (ZGoOrder i a s ts c cur p t tZ l pd eI sC tk)
cast' _ = Nothing
-- Type to represent an order line item
@ -224,12 +232,17 @@ updateOrderTotals o =
(qpaid o)
(qexternalInvoice o)
(qshortCode o)
(qtoken o)
where
newTotal :: ZGoOrder -> Double
newTotal x = foldr tallyItems 0 (qlines x)
tallyItems :: LineItem -> Double -> Double
tallyItems y z = (lqty y * lcost y) + z
setOrderToken :: T.Text -> ZGoOrder -> ZGoOrder
setOrderToken token (ZGoOrder i a s ts c cur p t tZ l pd eI sC tk) =
ZGoOrder i a s ts c cur p t tZ l pd eI sC token
findOrder :: T.Text -> Action IO (Maybe Document)
findOrder s = findOne (select ["session" =: s, "closed" =: False] "orders")

14
src/Owner.hs
View File

@ -366,8 +366,12 @@ instance ToJSON OwnerSettings where
, "expiration" .= e
, "payconf" .= pc
, "crmToken" .= cT
, "viewkey" .= (T.take 8 vK <> "...." <> T.takeEnd 8 vK)
, "viewkey" .= keyObfuscate vK
]
where
keyObfuscate s
| s == "" = ""
| otherwise = T.take 8 s <> "...." <> T.takeEnd 8 s
-- Helper Functions
getOwnerSettings :: Owner -> OwnerSettings
@ -407,6 +411,10 @@ findOwnerById :: T.Text -> Action IO (Maybe Document)
findOwnerById i =
findOne (select ["_id" =: (read (T.unpack i) :: ObjectId)] "owners")
findActiveOwners :: Action IO [Document]
findActiveOwners =
rest =<< find (select ["paid" =: True, "payconf" =: True] "owners")
-- | Function to find Owners about to expire
findExpiringOwners :: UTCTime -> Action IO [Document]
findExpiringOwners now =
@ -437,6 +445,10 @@ updateOwnerSettings os =
]
]
upsertViewingKey :: Owner -> String -> Action IO ()
upsertViewingKey o vk =
modify (select ["_id" =: o_id o] "owners") ["$set" =: ["viewKey" =: vk]]
-- | Type for a pro session
data ZGoProSession =
ZGoProSession

33
src/User.hs
View File

@ -69,6 +69,36 @@ instance FromJSON User where
""
v
instance Val User where
cast' (Doc 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
Just $ User i a s b p v
cast' _ = Nothing
val (User i a s b p v) =
case i of
Just oid ->
Doc
[ "_id" =: oid
, "address" =: a
, "session" =: s
, "blocktime" =: b
, "pin" =: p
, "validated" =: v
]
Nothing ->
Doc
[ "address" =: a
, "session" =: s
, "blocktime" =: b
, "pin" =: p
, "validated" =: v
]
parseUserBson :: B.Document -> Maybe User
parseUserBson d = do
i <- B.lookup "_id" d
@ -84,6 +114,9 @@ parseUserBson d = do
findUser :: T.Text -> Action IO (Maybe Document)
findUser s = findOne (select ["session" =: s] "users")
findUserById :: String -> Action IO (Maybe Document)
findUserById i = findOne (select ["_id" =: (read i :: B.ObjectId)] "users")
-- | Function to delete user by ID
deleteUser :: String -> Action IO ()
deleteUser i = deleteOne (select ["_id" =: (read i :: B.ObjectId)] "users")

53
src/WooCommerce.hs
View File

@ -28,6 +28,29 @@ data WooToken =
}
deriving (Eq, Show)
instance FromJSON WooToken where
parseJSON =
withObject "WooToken" $ \obj -> do
i <- obj .:? "_id"
o <- obj .: "ownerid"
t <- obj .: "token"
u <- obj .: "siteurl"
pure $ WooToken (read <$> i) (read o) t u
instance ToJSON WooToken where
toJSON (WooToken i o t u) =
case i of
Just oid ->
object
["_id" .= show oid, "ownerid" .= show o, "token" .= t, "siteurl" .= u]
Nothing ->
object
[ "_id" .= ("" :: String)
, "ownerid" .= show o
, "token" .= t
, "siteurl" .= u
]
instance Val WooToken where
val (WooToken i o t u) =
if isJust i
@ -47,8 +70,11 @@ instance Val WooToken where
cast' _ = Nothing
-- Database actions
findWooToken :: ObjectId -> Action IO (Maybe Document)
findWooToken oid = findOne (select ["owner" =: oid] "wootokens")
findWooToken :: Maybe ObjectId -> Action IO (Maybe Document)
findWooToken oid =
case oid of
Nothing -> return Nothing
Just o -> findOne (select ["owner" =: o] "wootokens")
addUrl :: WooToken -> T.Text -> Action IO ()
addUrl t u =
@ -63,8 +89,9 @@ payWooOrder ::
-> BS.ByteString -- Total ZEC for order
-> IO ()
payWooOrder u i o t p z = do
wooReq <- parseRequest $ u ++ "/wc-api/zpmtcallback"
wooReq <- parseRequest u
let req =
setRequestPath "/wp-json/wc/v3/zgocallback" $
setRequestQueryString
[ ("token", Just t)
, ("orderid", Just o)
@ -77,23 +104,15 @@ payWooOrder u i o t p z = do
res <- httpLBS req
if getResponseStatus res == ok200
then return ()
else error "Failed to report payment to WooCommerce"
else do
print $ getResponseStatus res
error "Failed to report payment to WooCommerce"
generateWooToken :: Owner -> Action IO ()
generateWooToken o =
generateWooToken :: Owner -> String -> Action IO ()
generateWooToken o s =
case o_id o of
Just ownerid -> do
let tokenHash =
BLK.hash
[ BA.pack . BS.unpack . C.pack . T.unpack $ oname o <> oaddress o :: BA.Bytes
]
let wooToken =
val $
WooToken
Nothing
ownerid
(T.pack . show $ (tokenHash :: BLK.Digest BLK.DEFAULT_DIGEST_LEN))
Nothing
let wooToken = val $ WooToken Nothing ownerid (T.pack s) Nothing
case wooToken of
Doc wT -> insert_ "wootokens" wT
_ -> error "Couldn't create the WooCommerce token"

21
src/Xero.hs
View File

@ -171,6 +171,26 @@ instance FromJSON XeroTenant where
--u <- obj .: "updatedDateUtc"
pure $ XeroTenant i aei tI tT tN
data XeroInvoiceRequest =
XeroInvoiceRequest
{ xr_owner :: T.Text
, xr_invNo :: T.Text
, xr_amount :: Double
, xr_currency :: T.Text
, xr_shortCode :: T.Text
}
deriving (Show, Eq)
instance FromJSON XeroInvoiceRequest where
parseJSON =
withObject "XeroInvoiceRequest" $ \obj -> do
o <- obj .: "ownerId"
i <- obj .: "invoice"
a <- obj .: "amount"
c <- obj .: "currency"
s <- obj .: "shortcode"
pure $ XeroInvoiceRequest o i a c s
data XeroInvoice =
XeroInvoice
{ xi_id :: Maybe ObjectId
@ -443,5 +463,6 @@ payXeroInvoice pipe dbName inv address amt zec = do
setRequestHost "api.xero.com" $
setRequestMethod "PUT" defaultRequest
res <- httpJSON req :: IO (Response Object)
print res
return ()
else error "Invalid parameters"

814
src/ZGoBackend.hs
View File

@ -12,6 +12,8 @@ import Control.Concurrent (forkIO, threadDelay)
import Control.Exception (try)
import Control.Monad
import Control.Monad.IO.Class
import Crypto.RNG (newCryptoRNGState, runCryptoRNGT)
import Crypto.RNG.Utils (randomString)
import Data.Aeson
import Data.Array
import qualified Data.Bson as B
@ -37,7 +39,7 @@ import qualified Data.UUID as U
import qualified Data.Vector as V
import Data.Vector.Internal.Check (doChecks)
import Data.Word
import Database.MongoDB
import Database.MongoDB hiding (Order)
import Debug.Trace
import GHC.Generics
import Item
@ -64,6 +66,9 @@ import Web.Scotty
import WooCommerce
import Xero
import ZGoTx
import ZcashHaskell.Sapling
import ZcashHaskell.Types (RawData(..))
import ZcashHaskell.Utils (decodeBech32)
-- Models for API objects
-- | A type to model Zcash RPC calls
@ -586,7 +591,7 @@ routes pipe config = do
simpleCorsResourcePolicy
{ corsRequestHeaders = ["Authorization", "Content-Type"]
, corsMethods = "DELETE" : simpleMethods
--, corsOrigins = Nothing
, corsOrigins = Nothing
}
middleware $
basicAuth
@ -623,102 +628,288 @@ routes pipe config = do
])
get "/api/xerotoken" $ do
code <- param "code"
address <- param "address"
session <- param "session"
user <- liftAndCatchIO $ run (findUser session)
xeroConfig <- liftAndCatchIO $ run findXero
case xeroConfig of
case cast' . Doc =<< xeroConfig of
Nothing -> status noContent204
Just x -> do
let xConfig = cast' (Doc x)
case xConfig of
Nothing -> status noContent204
Just c -> do
Just c -> do
case cast' . Doc =<< user of
Nothing -> status unauthorized401
Just u -> do
res <-
liftAndCatchIO $
requestXeroToken pipe (c_dbName config) c code address
requestXeroToken pipe (c_dbName config) c code $ uaddress u
if res
then status ok200
else status noContent204
get "/api/invdata" $ do
inv <- param "inv"
oAddress <- param "address"
post "/invdata" $ do
invData <- jsonData
xeroConfig <- liftAndCatchIO $ run findXero
case xeroConfig of
let invReq = payload (invData :: Payload XeroInvoiceRequest)
case cast' . Doc =<< xeroConfig of
Nothing -> do
status noContent204
text "Xero App credentials not found"
Just x -> do
let xConfig = cast' (Doc x)
case xConfig of
status ok200
Web.Scotty.json
(object
[ "reportType" .= (1 :: Integer)
, "order" .= (Nothing :: Maybe ZGoOrder)
, "shop" .= (Nothing :: Maybe String)
])
Just c -> do
o <- liftAndCatchIO $ run $ findOwnerById $ xr_owner invReq
case cast' . Doc =<< o of
Nothing -> do
status noContent204
text "Xero App credentials corrupted"
Just c -> do
res <-
status ok200
Web.Scotty.json
(object
[ "reportType" .= (2 :: Integer)
, "order" .= (Nothing :: Maybe ZGoOrder)
, "shop" .= (Nothing :: Maybe String)
])
Just o' -> do
existingOrder <-
liftAndCatchIO $
requestXeroToken pipe (c_dbName config) c "none" oAddress
if res
then do
resInv <-
run $
findXeroOrder
(oaddress o')
(xr_invNo invReq)
(xr_shortCode invReq)
case cast' . Doc =<< existingOrder of
Nothing -> do
res <-
liftAndCatchIO $
getXeroInvoice pipe (c_dbName config) inv oAddress
case resInv of
Nothing -> do
status noContent204
text "Xero invoice not found"
Just xI -> do
requestXeroToken pipe (c_dbName config) c "none" $ oaddress o'
if res
then do
resInv <-
liftAndCatchIO $
getXeroInvoice pipe (c_dbName config) (xr_invNo invReq) $
oaddress o'
case resInv of
Nothing -> do
status ok200
Web.Scotty.json
(object
[ "reportType" .= (2 :: Integer)
, "order" .= (Nothing :: Maybe ZGoOrder)
, "shop" .= (Nothing :: Maybe String)
])
Just xI -> do
if xi_type xI == "ACCREC"
then if xi_status xI == "AUTHORISED"
then if xi_currency xI ==
T.toUpper (ocurrency o')
then if xi_total xI == xr_amount invReq
then do
now <- liftIO getCurrentTime
tk <- liftIO generateToken
pr <-
liftAndCatchIO $
run
(findPrice $
T.unpack . ocurrency $ o')
case parseZGoPrice =<< pr of
Nothing -> do
status ok200
Web.Scotty.json
(object
[ "reportType" .=
(7 :: Integer)
, "order" .=
(Nothing :: Maybe ZGoOrder)
, "shop" .=
(Nothing :: Maybe String)
])
Just cp -> do
let newOrder =
ZGoOrder
Nothing
(oaddress o')
("Xero-" <>
maybe
""
(T.pack . show)
(o_id o'))
now
True
(ocurrency o')
(price cp)
(xi_total xI)
(xi_total xI /
price cp)
[ LineItem
1
("Invoice from " <>
oname o' <>
" [" <>
xi_number xI <>
"]")
(xi_total xI)
]
False
(xi_number xI)
(xr_shortCode
invReq)
(T.pack tk)
_ <-
liftAndCatchIO $
run $
upsertOrder newOrder
finalOrder <-
liftAndCatchIO $
run $
findXeroOrder
(oaddress o')
(xi_number xI)
(xr_shortCode invReq)
case cast' . Doc =<<
finalOrder of
Nothing -> do
status
internalServerError500
text
"Unable to save order to DB"
Just fO -> do
status created201
Web.Scotty.json
(object
[ "reportType" .=
(0 :: Integer)
, "order" .=
toJSON
(fO :: ZGoOrder)
, "shop" .=
oname o'
])
else do
status ok200
Web.Scotty.json
(object
[ "reportType" .=
(8 :: Integer)
, "order" .=
(Nothing :: Maybe ZGoOrder)
, "shop" .=
(Nothing :: Maybe String)
])
else do
status ok200
Web.Scotty.json
(object
[ "reportType" .= (7 :: Integer)
, "order" .=
(Nothing :: Maybe ZGoOrder)
, "shop" .=
(Nothing :: Maybe String)
])
else do
status ok200
Web.Scotty.json
(object
[ "reportType" .= (6 :: Integer)
, "order" .= (Nothing :: Maybe ZGoOrder)
, "shop" .= (Nothing :: Maybe String)
])
else do
status ok200
Web.Scotty.json
(object
[ "reportType" .= (5 :: Integer)
, "order" .= (Nothing :: Maybe ZGoOrder)
, "shop" .= (Nothing :: Maybe String)
])
else do
status ok200
Web.Scotty.json (object ["invdata" .= toJSON xI])
else status noContent204
Web.Scotty.json
(object
[ "reportType" .= (1 :: Integer)
, "order" .= (Nothing :: Maybe ZGoOrder)
, "shop" .= (Nothing :: Maybe String)
])
Just eO -> do
status created201
Web.Scotty.json
(object
[ "reportType" .= (0 :: Integer)
, "order" .= toJSON (eO :: ZGoOrder)
, "shop" .= oname o'
])
-- Get the xeroaccount code
get "/api/xeroaccount" $ do
oAdd <- param "address"
res <- liftAndCatchIO $ run (findToken oAdd)
let c = cast' . Doc =<< res
case c of
Nothing -> status noContent204
Just c1 -> do
status ok200
Web.Scotty.json
(object
[ "message" .= ("Xero account code found" :: String)
, "code" .= t_code c1
])
session <- param "session"
user <- liftAndCatchIO $ run (findUser session)
case cast' . Doc =<< user of
Nothing -> status unauthorized401
Just u -> do
res <- liftAndCatchIO $ run (findToken $ uaddress u)
let c = cast' . Doc =<< res
case c of
Nothing -> status noContent204
Just c1 -> do
status ok200
Web.Scotty.json
(object
[ "message" .= ("Xero account code found" :: String)
, "code" .= t_code c1
])
-- Save the xeroaccount code
post "/api/xeroaccount" $ do
oAdd <- param "address"
session <- param "session"
c <- param "code"
liftAndCatchIO $ run (addAccCode oAdd c)
status accepted202
user <- liftAndCatchIO $ run (findUser session)
case cast' . Doc =<< user of
Nothing -> status unauthorized401
Just u -> do
let oAdd = uaddress u
liftAndCatchIO $ run (addAccCode oAdd c)
status accepted202
-- Get the WooCommerce token
get "/api/wootoken" $ do
oid <- param "ownerid"
res <- liftAndCatchIO $ run (findWooToken (read oid))
let t1 = cast' . Doc =<< res
case t1 of
Nothing -> status noContent204
Just t -> do
status ok200
Web.Scotty.json
(object
[ "ownerid" .= show (w_owner t)
, "token" .= w_token t
, "siteurl" .= w_url t
])
session <- param "session"
user <- liftAndCatchIO $ run (findUser session)
case cast' . Doc =<< user of
Nothing -> status unauthorized401
Just u -> do
owner <- liftAndCatchIO $ run (findOwner $ uaddress u)
case cast' . Doc =<< owner of
Nothing -> status internalServerError500
Just o -> do
res <- liftAndCatchIO $ run (findWooToken $ o_id o)
let t1 = cast' . Doc =<< res
case t1 of
Nothing -> status noContent204
Just t -> do
status ok200
Web.Scotty.json
(object
[ "ownerid" .= show (w_owner t)
, "token" .= w_token t
, "siteurl" .= w_url t
])
post "/api/wootoken" $ do
oid <- param "ownerid"
res <- liftAndCatchIO $ run (findOwnerById oid)
let o1 = cast' . Doc =<< res
case o1 of
Nothing -> status noContent204
Just o -> do
liftAndCatchIO $ run (generateWooToken o)
status accepted202
session <- param "session"
user <- liftAndCatchIO $ run (findUser session)
case cast' . Doc =<< user of
Nothing -> status unauthorized401
Just u -> do
res <- liftAndCatchIO $ run (findOwnerById oid)
case cast' . Doc =<< res of
Nothing -> status badRequest400
Just o -> do
if oaddress o == uaddress u
then do
tk <- liftIO generateToken
liftAndCatchIO $ run (generateWooToken o tk)
status accepted202
else status forbidden403
-- Authenticate the WooCommerce plugin
get "/auth" $ do
oid <- param "ownerid"
t <- param "token"
siteurl <- param "siteurl"
res <- liftAndCatchIO $ run (findWooToken (read oid))
res <- liftAndCatchIO $ run (findWooToken $ Just (read oid))
let c1 = cast' . Doc =<< res
case c1 of
Nothing -> do
@ -727,7 +918,7 @@ routes pipe config = do
(object
["authorized" .= False, "message" .= ("Owner not found" :: String)])
Just c ->
if t == w_token c
if blk3Hash t == blk3Hash (T.unpack $ w_token c)
then if isNothing (w_url c)
then do
liftAndCatchIO $ run (addUrl c siteurl)
@ -765,6 +956,10 @@ routes pipe config = do
[ "authorized" .= False
, "message" .= ("Token mismatch" :: String)
])
where blk3Hash :: String -> String
blk3Hash s =
show
(BLK.hash [BA.pack . BS.unpack . C.pack $ s :: BA.Bytes] :: BLK.Digest BLK.DEFAULT_DIGEST_LEN)
get "/woopayment" $ do
oid <- param "ownerid"
t <- param "token"
@ -774,7 +969,7 @@ routes pipe config = do
amount <- param "amount"
sUrl <- param "siteurl"
orderKey <- param "orderkey"
res <- liftAndCatchIO $ run (findWooToken (read oid))
res <- liftAndCatchIO $ run (findWooToken $ Just (read oid))
let c = cast' . Doc =<< res
case c of
Nothing -> do
@ -806,6 +1001,7 @@ routes pipe config = do
Just o ->
if opaid o
then do
tk <- liftIO generateToken
let newOrder =
ZGoOrder
Nothing
@ -832,9 +1028,11 @@ routes pipe config = do
(T.concat
[T.pack sUrl, "-", ordId, "-", orderKey])
""
(T.pack tk)
newId <- liftAndCatchIO $ run (insertWooOrder newOrder)
status ok200
Web.Scotty.json (object ["order" .= show newId])
Web.Scotty.json
(object ["order" .= show newId, "token" .= tk])
else do
status accepted202
Web.Scotty.json
@ -893,12 +1091,20 @@ routes pipe config = do
--Delete user
Web.Scotty.delete "/api/user/:id" $ do
userId <- param "id"
session <- param "session"
let r = mkRegex "^[a-f0-9]{24}$"
if matchTest r userId
then do
liftAndCatchIO $ run (deleteUser userId)
status ok200
else status noContent204
u <- liftAndCatchIO $ run (findUserById userId)
case cast' . Doc =<< u of
Nothing -> status badRequest400
Just u' ->
if session == usession u'
then do
liftAndCatchIO $ run (deleteUser userId)
status ok200
else status forbidden403
else status badRequest400
--Get current blockheight from Zcash node
get "/blockheight" $ do
blockInfo <-
@ -929,7 +1135,7 @@ routes pipe config = do
[ "message" .= ("Owner found!" :: String)
, "owner" .= getOwnerSettings o
])
get "/api/ownerid" $ do
get "/ownerid" $ do
id <- param "id"
owner <- liftAndCatchIO $ run (findOwnerById id)
case owner of
@ -943,23 +1149,7 @@ routes pipe config = do
Web.Scotty.json
(object
[ "message" .= ("Owner found!" :: String)
, "owner" .=
object
[ "_id" .= (maybe "" show $ o_id q :: String)
, "address" .= oaddress q
, "name" .= oname q
, "currency" .= ocurrency q
, "tax" .= otax q
, "taxValue" .= otaxValue q
, "vat" .= ovat q
, "vatValue" .= ovatValue q
, "paid" .= opaid q
, "zats" .= ozats q
, "invoices" .= oinvoices q
, "expiration" .= oexpiration q
, "payconf" .= opayconf q
, "crmToken" .= ocrmToken q
]
, "owner" .= getOwnerSettings q
])
--Upsert owner to DB
post "/api/owner" $ do
@ -1015,33 +1205,99 @@ routes pipe config = do
liftAndCatchIO $ run $ updateOwnerSettings q
status accepted202
else status noContent204
post "/api/ownervk" $ do
s <- param "session"
u <- liftAndCatchIO $ run (findUser s)
o <- jsonData
let q = payload (o :: Payload String)
let qRaw = decodeBech32 $ C.pack q
if hrp qRaw == "fail"
then status badRequest400
else do
let qBytes = bytes qRaw
case cast' . Doc =<< u of
Nothing -> status unauthorized401
Just u' -> do
if isValidSaplingViewingKey qBytes
then if matchSaplingAddress
qBytes
(bytes . decodeBech32 . C.pack . T.unpack $ uaddress u')
then do
owner <- liftAndCatchIO $ run (findOwner $ uaddress u')
case cast' . Doc =<< owner of
Nothing -> status badRequest400
Just o' -> do
unless (oviewkey o' /= "") $ do
vkInfo <-
liftAndCatchIO $
makeZcashCall
nodeUser
nodePwd
"z_importviewingkey"
[ Data.Aeson.String (T.strip . T.pack $ q)
, "no"
]
let content =
getResponseBody vkInfo :: RpcResponse Object
if isNothing (err content)
then do
_ <-
liftAndCatchIO $ run (upsertViewingKey o' q)
status created201
else do
text $ L.pack . show $ err content
status badRequest400
else status forbidden403
else status badRequest400
--Get items associated with the given address
get "/api/items" $ do
addr <- param "address"
items <- liftAndCatchIO $ run (findItems addr)
case items of
[] -> status noContent204
_ -> do
let pItems = map (cast' . Doc) items :: [Maybe Item]
status ok200
Web.Scotty.json
(object
["message" .= ("Items found!" :: String), "items" .= toJSON pItems])
session <- param "session"
user <- liftAndCatchIO $ run (findUser session)
case cast' . Doc =<< user of
Nothing -> status forbidden403
Just u -> do
items <- liftAndCatchIO $ run (findItems $ uaddress u)
case items of
[] -> status noContent204
_ -> do
let pItems = map (cast' . Doc) items :: [Maybe Item]
status ok200
Web.Scotty.json
(object
[ "message" .= ("Items found!" :: String)
, "items" .= toJSON pItems
])
--Upsert item
post "/api/item" $ do
i <- jsonData
let q = payload (i :: Payload Item)
_ <- liftAndCatchIO $ run (upsertItem q)
status created201
session <- param "session"
user <- liftAndCatchIO $ run (findUser session)
case cast' . Doc =<< user of
Nothing -> status forbidden403
Just u -> do
let q = payload (i :: Payload Item)
if uaddress u == iowner q
then do
_ <- liftAndCatchIO $ run (upsertItem q)
status created201
else status forbidden403
--Delete item
Web.Scotty.delete "/api/item/:id" $ do
session <- param "session"
oId <- param "id"
let r = mkRegex "^[a-f0-9]{24}$"
if matchTest r oId
then do
liftAndCatchIO $ run (deleteItem oId)
status ok200
else status noContent204
u' <- liftAndCatchIO $ checkUser run session
case u' of
Nothing -> status forbidden403
Just u -> do
i <- liftAndCatchIO $ run (findItemById oId)
case cast' . Doc =<< i of
Nothing -> status badRequest400
Just i' -> do
if iowner i' == uaddress u
then do
liftAndCatchIO $ run (deleteItem oId)
status ok200
else status forbidden403
--Get price for Zcash
get "/price" $ do
curr <- param "currency"
@ -1057,39 +1313,48 @@ routes pipe config = do
])
--Get all closed orders for the address
get "/api/allorders" $ do
addr <- param "address"
myOrders <- liftAndCatchIO $ run (findAllOrders addr)
case myOrders of
[] -> status noContent204
_ -> do
let pOrders = map (cast' . Doc) myOrders :: [Maybe ZGoOrder]
status ok200
Web.Scotty.json
(object
[ "message" .= ("Orders found!" :: String)
, "orders" .= toJSON pOrders
])
session <- param "session"
user <- liftAndCatchIO $ run (findUser session)
case cast' . Doc =<< user of
Nothing -> status unauthorized401
Just u -> do
myOrders <- liftAndCatchIO $ run (findAllOrders $ uaddress u)
case myOrders of
[] -> status noContent204
_ -> do
let pOrders = map (cast' . Doc) myOrders :: [Maybe ZGoOrder]
status ok200
Web.Scotty.json
(object
[ "message" .= ("Orders found!" :: String)
, "orders" .= toJSON pOrders
])
--Get order by id for receipts
get "/api/order/:id" $ do
get "/order/:id" $ do
oId <- param "id"
token <- param "token"
let r = mkRegex "^[a-f0-9]{24}$"
if matchTest r oId
then do
myOrder <- liftAndCatchIO $ run (findOrderById oId)
case myOrder of
case cast' . Doc =<< 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)
])
else status noContent204
Just pOrder -> do
if qtoken pOrder == token
then do
shop <- liftAndCatchIO $ run (findOwner $ qaddress pOrder)
case cast' . Doc =<< shop of
Nothing -> status badRequest400
Just s -> do
status ok200
Web.Scotty.json
(object
[ "message" .= ("Order found!" :: String)
, "order" .= toJSON (pOrder :: ZGoOrder)
, "shop" .= (oname s :: T.Text)
])
else status forbidden403
else status badRequest400
--Get order by session
get "/api/order" $ do
sess <- param "session"
@ -1132,13 +1397,37 @@ routes pipe config = do
post "/api/order" $ do
newOrder <- jsonData
let q = payload (newOrder :: Payload ZGoOrder)
_ <- liftAndCatchIO $ run (upsertOrder q)
status created201
session <- param "session"
user <- liftAndCatchIO $ run (findUser session)
case cast' . Doc =<< user of
Nothing -> status unauthorized401
Just u -> do
if uaddress u == qaddress q
then do
if qtoken q == ""
then do
t <- liftIO generateToken
_ <-
liftAndCatchIO $
run (upsertOrder $ setOrderToken (T.pack t) q)
status created201
else do
_ <- liftAndCatchIO $ run (upsertOrder q)
status created201
else status forbidden403
--Delete order
Web.Scotty.delete "/api/order/:id" $ do
oId <- param "id"
liftAndCatchIO $ run (deleteOrder oId)
status ok200
session <- param "session"
o <- liftAndCatchIO $ run (findOrderById oId)
case cast' . Doc =<< o of
Nothing -> status badRequest400
Just order -> do
if qsession order == session
then do
liftAndCatchIO $ run (deleteOrder oId)
status ok200
else status forbidden403
-- Get language for component
get "/getmainlang" $ do
lang <- param "lang"
@ -1164,6 +1453,22 @@ routes pipe config = do
Just textPack -> do
status ok200
Web.Scotty.json $ toJSON (textPack :: LangComponent)
get "/getinvoicelang" $ do
lang <- param "lang"
txtPack' <- liftAndCatchIO $ run (findLangComponent lang "invoice")
case cast' . Doc =<< txtPack' of
Nothing -> status noContent204
Just textPack -> do
status ok200
Web.Scotty.json $ toJSON (textPack :: LangComponent)
get "/getpmtservicelang" $ do
lang <- param "lang"
txtPack' <- liftAndCatchIO $ run (findLangComponent lang "pmtservice")
case cast' . Doc =<< txtPack' of
Nothing -> status noContent204
Just textPack -> do
status ok200
Web.Scotty.json $ toJSON (textPack :: LangComponent)
get "/api/getlang" $ do
component <- param "component"
lang <- param "lang"
@ -1251,36 +1556,10 @@ listTxs user pwd a confs = do
Just e -> return $ Left $ "Error reading transactions: " <> emessage e
Left ex -> return $ Left $ (T.pack . show) ex
-- | Function to check the ZGo full node for new txs
scanZcash :: Config -> Pipe -> IO ()
scanZcash config pipe = do
myTxs <-
listTxs (c_nodeUser config) (c_nodePwd config) (c_nodeAddress config) 1
case myTxs of
Right txs -> do
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}).*"
let p =
mkRegex
".*ZGOp::([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}).*"
let y =
mkRegex
".*MSG\\s(zs[a-z0-9]{76})\\s+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}).*"
let k = map zToZGoTx (filter (isRelevant r) txs)
mapM_ (access pipe master (c_dbName config) . upsertZGoTx "txs") k
let j = map zToZGoTx (filter (isRelevant p) txs)
mapM_ (upsertPayment pipe (c_dbName config)) j
let l = map zToZGoTx (filter (isRelevant y) txs)
mapM_ (access pipe master (c_dbName config) . upsertZGoTx "txs") l
Left e -> do
putStrLn $ "Error scanning node transactions: " ++ T.unpack e
return ()
-- | Function to filter transactions
isRelevant :: Text.Regex.Regex -> ZcashTx -> Bool
isRelevant re t
| zconfirmations t < 100 && (matchTest re . T.unpack . zmemo) t = True
isRelevant :: Integer -> Text.Regex.Regex -> ZcashTx -> Bool
isRelevant conf re t
| zconfirmations t < conf && (matchTest re . T.unpack . zmemo) t = True
| otherwise = False
-- | New function to scan transactions with parser
@ -1296,85 +1575,103 @@ scanZcash' config pipe = do
-- | Function to scan loaded viewing keys for payments
scanPayments :: Config -> Pipe -> IO ()
scanPayments config pipe = do
shops <- listAddresses (c_nodeUser config) (c_nodePwd config)
mapM_ (findPaidOrders config pipe) shops
where
findPaidOrders :: Config -> Pipe -> ZcashAddress -> IO ()
findPaidOrders c p z = do
paidTxs <- listTxs (c_nodeUser c) (c_nodePwd c) (addy z) 5
case paidTxs of
Right txs -> do
let r = mkRegex ".*ZGo Order::([0-9a-fA-F]{24}).*"
let k = filter (isRelevant r) txs
let j = map (getOrderId r) k
mapM_ (recordPayment p (c_dbName config)) j
mapM_ (access p master (c_dbName config) . markOrderPaid) j
Left e -> print e
getOrderId :: Text.Regex.Regex -> ZcashTx -> (String, Double)
getOrderId re t = do
let reg = matchAllText re (T.unpack $ zmemo t)
if not (null reg)
then (fst $ head reg ! 1, zamount t)
else ("", 0)
recordPayment :: Pipe -> T.Text -> (String, Double) -> IO ()
recordPayment p dbName x = do
o <- access p master dbName $ findOrderById (fst x)
let xOrder = o >>= (cast' . Doc)
case xOrder of
Nothing -> error "Failed to retrieve order from database"
Just xO ->
when
(not (qpaid xO) &&
qexternalInvoice xO /= "" && qtotalZec xO == snd x) $ do
let sReg = mkRegex "(.*)-([a-fA-f0-9]{24})"
let sResult = matchAllText sReg (T.unpack $ qsession xO)
if not (null sResult)
then case fst $ head sResult ! 1 of
"Xero" -> do
xeroConfig <- access p master dbName findXero
let xC = xeroConfig >>= (cast' . Doc)
case xC of
Nothing -> error "Failed to read Xero config"
Just xConf -> do
requestXeroToken p dbName xConf "" (qaddress xO)
payXeroInvoice
p
dbName
(qexternalInvoice xO)
(qaddress xO)
(qtotal xO)
(qtotalZec xO)
"WC" -> do
let wOwner = fst $ head sResult ! 2
wooT <-
access p master dbName $ findWooToken (read wOwner)
let wT = wooT >>= (cast' . Doc)
case wT of
Nothing -> error "Failed to read WooCommerce token"
Just wt -> do
let iReg = mkRegex "(.*)-(.*)-.*"
let iResult =
matchAllText
iReg
(T.unpack $ qexternalInvoice xO)
if not (null iResult)
then do
let wUrl =
E.decodeUtf8With lenientDecode .
B64.decodeLenient . C.pack $
fst $ head iResult ! 1
let iNum = fst $ head iResult ! 2
payWooOrder
(T.unpack wUrl)
(C.pack iNum)
(C.pack $ maybe "" show (q_id xO))
(C.pack . T.unpack $ w_token wt)
(C.pack . show $ qprice xO)
(C.pack . show $ qtotalZec xO)
else error
"Couldn't parse externalInvoice for WooCommerce"
_ -> putStrLn "Not an integration order"
else putStrLn "Not an integration order"
shopRecords <- access pipe master (c_dbName config) findActiveOwners
case shopRecords of
[] -> return ()
_ -> do
let shops = cast' . Doc <$> shopRecords :: [Maybe Owner]
let validShopAddresses = map (maybe "" oaddress) $ filter isJust shops
mapM_ (findPaidOrders config pipe) validShopAddresses
where findPaidOrders :: Config -> Pipe -> T.Text -> IO ()
findPaidOrders c p z = do
print z
paidTxs <- listTxs (c_nodeUser c) (c_nodePwd c) z 5
case paidTxs of
Right txs -> do
let r = mkRegex ".*ZGo Order::([0-9a-fA-F]{24}).*"
let k = filter (isRelevant (c_confirmations c) r) txs
print k
let j = map (getOrderId r) k
mapM_ (recordPayment p (c_dbName config) z) j
Left e -> print e
getOrderId :: Text.Regex.Regex -> ZcashTx -> (String, Double)
getOrderId re t = do
let reg = matchAllText re (T.unpack $ zmemo t)
if not (null reg)
then (fst $ head reg ! 1, zamount t)
else ("", 0)
recordPayment ::
Pipe -> T.Text -> T.Text -> (String, Double) -> IO ()
recordPayment p dbName z x = do
print x
o <- access p master dbName $ findOrderById (fst x)
let xOrder = o >>= (cast' . Doc)
case xOrder of
Nothing -> error "Failed to retrieve order from database"
Just xO ->
when
(not (qpaid xO) && qtotalZec xO == snd x && z == qaddress xO) $ do
let sReg = mkRegex "(.*)-([a-fA-f0-9]{24})"
let sResult = matchAllText sReg (T.unpack $ qsession xO)
if not (null sResult)
then case fst $ head sResult ! 1 of
"Xero" -> do
xeroConfig <- access p master dbName findXero
let xC = xeroConfig >>= (cast' . Doc)
case xC of
Nothing -> error "Failed to read Xero config"
Just xConf -> do
requestXeroToken
p
dbName
xConf
""
(qaddress xO)
payXeroInvoice
p
dbName
(qexternalInvoice xO)
(qaddress xO)
(qtotal xO)
(qtotalZec xO)
liftIO $
access p master dbName $ markOrderPaid x
"WC" -> do
let wOwner = fst $ head sResult ! 2
wooT <-
access p master dbName $
findWooToken $ Just (read wOwner)
let wT = wooT >>= (cast' . Doc)
case wT of
Nothing ->
error "Failed to read WooCommerce token"
Just wt -> do
let iReg = mkRegex "(.*)-(.*)-.*"
let iResult =
matchAllText
iReg
(T.unpack $ qexternalInvoice xO)
if not (null iResult)
then do
let wUrl =
E.decodeUtf8With lenientDecode .
B64.decodeLenient . C.pack $
fst $ head iResult ! 1
let iNum = fst $ head iResult ! 2
payWooOrder
(T.unpack wUrl)
(C.pack iNum)
(C.pack $ maybe "" show (q_id xO))
(C.pack . T.unpack $ w_token wt)
(C.pack . show $ qprice xO)
(C.pack . show $ qtotalZec xO)
liftIO $
access p master dbName $
markOrderPaid x
else error
"Couldn't parse externalInvoice for WooCommerce"
_ -> putStrLn "Not an integration order"
else liftIO $ access p master dbName $ markOrderPaid x
-- | RPC methods
-- | List addresses with viewing keys loaded
@ -1537,4 +1834,17 @@ expireProSessions pipe db = do
access pipe master db $ removePro (psaddress z)
access pipe master db $ closeProSession z
checkUser ::
(Action IO (Maybe Document) -> IO (Maybe Document))
-> T.Text
-> IO (Maybe User)
checkUser run s = do
user <- run (findUser s)
return $ cast' . Doc =<< user
generateToken :: IO String
generateToken = do
rngState <- newCryptoRNGState
runCryptoRNGT rngState $ randomString 24 "abcdef0123456789"
debug = flip trace

14
src/ZGoTx.hs
View File

@ -119,7 +119,6 @@ type Parser = Parsec Void T.Text
pSession :: Parser MemoToken
pSession = do
optional spaceChar
string "ZGO"
pay <- optional $ char 'p'
string "::"
@ -142,13 +141,18 @@ pSaplingAddress = do
pMsg :: Parser MemoToken
pMsg = do
Msg . T.pack <$>
some (alphaNumChar <|> punctuationChar <|> charCategory OtherSymbol)
msg <-
some
(alphaNumChar <|> punctuationChar <|> symbolChar <|>
charCategory OtherSymbol)
pure $ Msg . T.pack $ msg
pMemo :: Parser MemoToken
pMemo = do
optional spaceChar
pSession <|> pSaplingAddress <|> pMsg
optional $ some spaceChar
t <- pSession <|> pSaplingAddress <|> pMsg
optional $ some spaceChar
return t
isMemoToken :: T.Text -> MemoToken -> Bool
isMemoToken kind t =

12
stack.yaml
View File

@ -17,7 +17,7 @@
#
# resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml
resolver: lts-20.19
resolver: lts-20.23
#url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/4.yaml
# User packages to be built.
@ -44,6 +44,16 @@ packages:
extra-deps:
- git: https://github.com/reach-sh/haskell-hexstring.git
commit: 085c16fb21b9f856a435a3faab980e7e0b319341
- git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git
commit: fef3d3af35a09db718cddb8fc9166b2d2691a744
- git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git
commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05
- git: https://github.com/well-typed/borsh.git
commit: d2fcfa159e0a844b1ec5e8ed3e232d4b380fa831
- aeson-2.1.2.1@sha256:5b8d62a60963a925c4d123a46e42a8e235a32188522c9f119f64ac228c2612a7,6359
- vector-0.13.0.0@sha256:fa5cac81a17a5af388716792e8b99c24b3b66770086756d0d8b23f8272a0244c,9112
- generically-0.1.1
- vector-algorithms-0.9.0.1
- blake3-0.2@sha256:d1146b9a51ccfbb0532780778b6d016a614e3d44c05d8c1923dde9a8be869045,2448
- crypto-rng-0.3.0.1@sha256:04f4ae75943ecad8b794950985054130f272d65a588b6b6528f56df0bfedc4dc,1565
# Override default flag values for local packages and extra-deps

69
stack.yaml.lock
View File

@ -15,6 +15,67 @@ packages:
original:
commit: 085c16fb21b9f856a435a3faab980e7e0b319341
git: https://github.com/reach-sh/haskell-hexstring.git
- completed:
commit: fef3d3af35a09db718cddb8fc9166b2d2691a744
git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git
name: zcash-haskell
pantry-tree:
sha256: ec7782cf2646da17548d59af0ea98dcbaac1b6c2176258c696a7f508db6dbc21
size: 1126
version: 0.1.0
original:
commit: fef3d3af35a09db718cddb8fc9166b2d2691a744
git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git
- completed:
commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05
git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git
name: foreign-rust
pantry-tree:
sha256: be2f6fc0fab58a90fec657bdb6bd0ccf0810c7dccfe95c78b85e174fae227e42
size: 2315
version: 0.1.0
original:
commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05
git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git
- completed:
commit: d2fcfa159e0a844b1ec5e8ed3e232d4b380fa831
git: https://github.com/well-typed/borsh.git
name: borsh
pantry-tree:
sha256: 8335925f495a5a653fcb74b6b8bb18cd0b6b7fe7099a1686108704e6ab82f47b
size: 2268
version: 0.3.0
original:
commit: d2fcfa159e0a844b1ec5e8ed3e232d4b380fa831
git: https://github.com/well-typed/borsh.git
- completed:
hackage: aeson-2.1.2.1@sha256:5b8d62a60963a925c4d123a46e42a8e235a32188522c9f119f64ac228c2612a7,6359
pantry-tree:
sha256: 58d33beedd6e0ff79920c636d8a4295deb684b6e97c9b1ca94d3c780958d6302
size: 82465
original:
hackage: aeson-2.1.2.1@sha256:5b8d62a60963a925c4d123a46e42a8e235a32188522c9f119f64ac228c2612a7,6359
- completed:
hackage: vector-0.13.0.0@sha256:fa5cac81a17a5af388716792e8b99c24b3b66770086756d0d8b23f8272a0244c,9112
pantry-tree:
sha256: d2461d28022c8c0a91da08b579b1bff478f617102d2f5ef596cc5b28d14b8b6a
size: 4092
original:
hackage: vector-0.13.0.0@sha256:fa5cac81a17a5af388716792e8b99c24b3b66770086756d0d8b23f8272a0244c,9112
- completed:
hackage: generically-0.1.1@sha256:2b9b5efb6eea2fb65377565d53d85b0ccc5b37404fba4bef1d60277caa877e5e,1155
pantry-tree:
sha256: 98a8fe89d516d3752a9cc0af22cfa652f098cc6613da080762b63aa1d596e56d
size: 233
original:
hackage: generically-0.1.1
- completed:
hackage: vector-algorithms-0.9.0.1@sha256:f3e5c6695529a94edf762117cafd91c989cb642ad3f8ca4014dbb13c8f6c2a20,3826
pantry-tree:
sha256: aef389e57ae6020e5da719bee40aaf6cccf1c4d1e7743a85d30c9d8c25d170a0
size: 1510
original:
hackage: vector-algorithms-0.9.0.1
- completed:
hackage: blake3-0.2@sha256:d1146b9a51ccfbb0532780778b6d016a614e3d44c05d8c1923dde9a8be869045,2448
pantry-tree:
@ -31,7 +92,7 @@ packages:
hackage: crypto-rng-0.3.0.1@sha256:04f4ae75943ecad8b794950985054130f272d65a588b6b6528f56df0bfedc4dc,1565
snapshots:
- completed:
sha256: 42f77c84b34f68c30c2cd0bf8c349f617a0f428264362426290847a6a2019b64
size: 649618
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/19.yaml
original: lts-20.19
sha256: 4c972e067bae16b95961dbfdd12e07f1ee6c8fffabbfa05c3d65100b03f548b7
size: 650253
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/23.yaml
original: lts-20.23

614
test/Spec.hs
View File

@ -13,10 +13,12 @@ import Data.Either
import Data.Maybe
import Data.SecureMem
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import Data.Time
import Data.Time.Calendar
import Data.Time.Clock
import Data.Time.Clock.POSIX
import qualified Data.UUID as U
import Database.MongoDB
import Item
import LangComponent
@ -32,6 +34,7 @@ import Test.Hspec.QuickCheck
import Test.QuickCheck
import Test.QuickCheck.Gen
import Test.QuickCheck.Monadic
import Text.Megaparsec
import User
import Web.Scotty
import WooCommerce
@ -53,7 +56,31 @@ main = do
describe "hex strings" $ do
prop "encoding and decoding are inverse" $ \x ->
(decodeHexText . encodeHexText) x == x
describe "zToZGoTx" $ do
describe "zToZGoTx" $
--prop "memo parsing" testMemoParser
do
it "parse ZecWallet memo" $ do
let m =
runParser
pZGoMemo
"Zecwalllet memo"
"ZGO::5d3d4494-51c0-432d-8495-050419957aea\nReply-To:\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
case m of
Left e -> putStrLn $ errorBundlePretty e
Right m' ->
m_session m' `shouldBe`
U.fromString "5d3d4494-51c0-432d-8495-050419957aea"
it "parse YWallet memo" $ do
let m =
runParser
pZGoMemo
"Ywallet memo"
"\128737MSG\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e\n\nZGO::ad8477d3-4fdd-4c97-90b2-76630b5f77e1"
case m of
Left e -> putStrLn $ errorBundlePretty e
Right m' ->
m_session m' `shouldBe`
U.fromString "ad8477d3-4fdd-4c97-90b2-76630b5f77e1"
it "converts ZecWallet tx to ZGo tx" $ do
let t =
ZcashTx
@ -156,32 +183,13 @@ main = do
getResponseStatus res `shouldBe` accepted202
describe "Price endpoint" $ do
it "returns a price for an existing currency" $ do
req <-
testGet
"/api/price"
[ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
, ("currency", Just "usd")
]
req <- testGet "/price" [("currency", Just "usd")]
res <- httpJSON req
getResponseStatus (res :: Response A.Value) `shouldBe` ok200
it "returns 204 when the currency is not supported" $ do
req <-
testGet
"/api/price"
[ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
, ("currency", Just "jpy")
]
req <- testGet "/price" [("currency", Just "jpy")]
res <- httpLBS req
getResponseStatus res `shouldBe` noContent204
it "returs 401 when the session is not valid" $ do
req <-
testGet
"/api/price"
[ ("session", Just "th7s1sa-fake-6u1d-7h47-1m4deuph3r3")
, ("currency", Just "usd")
]
res <- httpLBS req
getResponseStatus res `shouldBe` unauthorized401
describe "Countries endpoint" $ do
it "returns a list of countries" $ do
req <-
@ -201,7 +209,7 @@ main = do
it "returns a block number" $ do
req <-
testGet
"/api/blockheight"
"/blockheight"
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
res <- httpJSON req
height (getResponseBody (res :: Response Block)) `shouldSatisfy` \x ->
@ -225,18 +233,32 @@ main = do
req <-
testGet
"/api/xeroaccount"
[ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
, ("address", Just "Zaddy")
]
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
res <- httpJSON req
getResponseStatus (res :: Response A.Value) `shouldBe` ok200
it "returns 401 with invalid session" $ do
it "reading returns 401 with invalid session" $ do
req <-
testGet
"/api/xeroaccount"
[("session", Just "fnelrkgnlyebrlvns82949")]
res <- httpLBS req
getResponseStatus res `shouldBe` unauthorized401
it "setting returns 401 with invalid session" $ do
req <-
testPost
"/api/xeroaccount"
[("session", Just "fnelrkgnlyebrlvns82949")]
res <- httpLBS req
getResponseStatus res `shouldBe` unauthorized401
it "setting succeeds with valid session" $ do
req <-
testPost
"/api/xeroaccount"
[ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
, ("code", Just "ZEC")
]
res <- httpLBS req
getResponseStatus res `shouldBe` accepted202
describe "User endpoint" $ do
it "returns a user for a session" $ do
req <-
@ -252,14 +274,39 @@ main = do
[("session", Just "suchafak-euui-dican-eve-nbelieveitca")]
res <- httpLBS req
getResponseStatus res `shouldBe` unauthorized401
it "deletes user by id" $ do
req <-
testDelete
"/api/user/"
"6272a90f2b05a74cf1000003"
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
res <- httpLBS req
getResponseStatus res `shouldBe` ok200
describe "delete" $ do
it "returns 401 when session is invalid" $ do
req <-
testDelete
"/api/user/"
"6272a90f2b05a74cf1000005"
[("session", Just "suchafak-euui-dican-eve-nbelieveitca")]
res <- httpLBS req
getResponseStatus res `shouldBe` unauthorized401
it "returns 403 when user and session don't match" $ do
req <-
testDelete
"/api/user/"
"6272a90f2b05a74cf1000005"
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
res <- httpLBS req
getResponseStatus res `shouldBe` forbidden403
it "returns 400 when user is invalid" $ do
req <-
testDelete
"/api/user/"
"000000000000000000000000"
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
res <- httpLBS req
getResponseStatus res `shouldBe` badRequest400
it "deletes user by id" $ do
req <-
testDelete
"/api/user/"
"6272a90f2b05a74cf1000003"
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdaa")]
res <- httpLBS req
getResponseStatus res `shouldBe` ok200
describe "Owner endpoint" $
--prop "add owner" testOwnerAdd
do
@ -294,8 +341,90 @@ main = do
]
res <- httpLBS req
getResponseStatus res `shouldBe` ok200
describe "Order endpoints" $ do
prop "upsert order" testOrderAdd
describe "Order endpoints" $
--prop "upsert order" testOrderAdd
do
it "adding order with bad session fails with 401" $ do
myTs <- liftIO getCurrentTime
let testOrder =
ZGoOrder
(Just (read "627ab3ea2b05a76be3000011"))
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
"35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd"
myTs
False
"usd"
102.0
0
0
[]
False
""
""
"testToken4321"
req <-
testPostJson "/api/order" $
A.object ["payload" A..= A.toJSON testOrder]
res <-
httpLBS $
setRequestQueryString
[("session", Just "35bfb9c2-9ad2-fake-adda-99d63b8dcdcd")]
req
getResponseStatus res `shouldBe` unauthorized401
it "adding order with mismatched session fails with 403" $ do
myTs <- liftIO getCurrentTime
let testOrder =
ZGoOrder
(Just (read "627ab3ea2b05a76be3000011"))
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
"35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd"
myTs
False
"usd"
102.0
0
0
[]
False
""
""
"testToken4321"
req <-
testPostJson "/api/order" $
A.object ["payload" A..= A.toJSON testOrder]
res <-
httpLBS $
setRequestQueryString
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dfake")]
req
getResponseStatus res `shouldBe` forbidden403
it "adding order with correct session succeeds" $ do
myTs <- liftIO getCurrentTime
let testOrder =
ZGoOrder
(Just (read "627ab3ea2b05a76be3000011"))
"zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4"
"35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd"
myTs
False
"usd"
102.0
0
0
[]
False
""
""
"testToken4321"
req <-
testPostJson "/api/order" $
A.object ["payload" A..= A.toJSON testOrder]
res <-
httpLBS $
setRequestQueryString
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
req
getResponseStatus res `shouldBe` created201
it "get order by session" $ do
req <-
testGet
@ -303,7 +432,7 @@ main = do
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
res <- httpJSON req
getResponseStatus (res :: Response A.Value) `shouldBe` ok200
it "get order by session fails when invalid" $ do
it "get order by session fails with bad session" $ do
req <-
testGet
"/api/order"
@ -313,40 +442,49 @@ main = do
it "get order by id" $ do
req <-
testGet
"/api/order/627ab3ea2b05a76be3000000"
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
"/order/627ab3ea2b05a76be3000000"
[("token", Just "testToken1234")]
res <- httpJSON req
getResponseStatus (res :: Response A.Value) `shouldBe` ok200
it "get order with wrong id" $ do
it "get order with invalid id fails with 400" $ do
req <- testGet "/order/6273hrb" [("token", Just "testToken1234")]
res <- httpLBS req
getResponseStatus res `shouldBe` badRequest400
it "get order by id fails with bad token" $ do
req <-
testGet
"/api/order/6273hrb"
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
"/order/627ab3ea2b05a76be3000000"
[("token", Just "wrongToken1234")]
res <- httpLBS req
getResponseStatus res `shouldBe` noContent204
it "get order by id fails with bad session" $ do
req <-
testGet
"/api/order/627ab3ea2b05a76be3000000"
[("session", Just "35bfb9c2-9ad2-4fe5-fake-99d63b8dcdcd")]
res <- httpLBS req
getResponseStatus res `shouldBe` unauthorized401
getResponseStatus res `shouldBe` forbidden403
it "get all orders for owner" $ do
req <-
testGet
"/api/allorders"
[ ("address", Just "Zaddy")
, ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
]
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
res <- httpJSON req
getResponseStatus (res :: Response A.Value) `shouldBe` ok200
it "get all orders for owner fails with bad session" $ do
req <-
testGet
"/api/allorders"
[ ("address", Just "Zaddy")
, ("session", Just "35bfb9c2-9ad2-4fe5-fake-99d63b8dcdcd")
]
[("session", Just "35bfb9c2-9ad2-4fe5-fake-99d63b8dcdcd")]
res <- httpLBS req
getResponseStatus res `shouldBe` unauthorized401
it "delete order by id fails with mismatched session" $ do
req <-
testDelete
"/api/order/"
"627ab3ea2b05a76be3000000"
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dfake")]
res <- httpLBS req
getResponseStatus res `shouldBe` forbidden403
it "delete order by id fails with bad session" $ do
req <-
testDelete
"/api/order/"
"627ab3ea2b05a76be3000000"
[("session", Just "35bfb9c2-9ad2-4fe5-fake-99d63b8dcdcd")]
res <- httpLBS req
getResponseStatus res `shouldBe` unauthorized401
it "delete order by id" $ do
@ -357,35 +495,98 @@ main = do
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
res <- httpLBS req
getResponseStatus res `shouldBe` ok200
it "delete order by id fails with bad session" $ do
req <-
testDelete
"/api/order/"
"627ab3ea2b05a76be3000000"
[("session", Just "35bfb9c2-9ad2-4fe5-fake-99d63b8dcdcd")]
res <- httpLBS req
getResponseStatus res `shouldBe` unauthorized401
describe "Item endpoint" $ do
prop "add item" testItemAdd
it "get items" $ do
it "adding item with bad session fails" $ do
let item =
Item
Nothing
"Table"
"Oak"
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
499.99
req <-
testPostJson "/api/item" $ A.object ["payload" A..= A.toJSON item]
res <-
httpLBS $
setRequestQueryString
[("session", Just "35bfb9c2-9ad2-fake-adda-99d63b8dcdcd")]
req
getResponseStatus res `shouldBe` unauthorized401
it "adding item with good session succeeds" $ do
let item =
Item
(Just (read "627d7ba92b05a76be3000013"))
"Table"
"Oak"
"zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4"
499.99
req <-
testPostJson "/api/item" $ A.object ["payload" A..= A.toJSON item]
res <-
httpLBS $
setRequestQueryString
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
req
getResponseStatus res `shouldBe` created201
it "get items with valid session succeeds" $ do
req <-
testGet
"/api/items"
[ ("address", Just "Zaddy")
, ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
]
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
res <- httpJSON req
getResponseStatus (res :: Response A.Value) `shouldBe` ok200
it "delete item" $ do
it "get items with invalid session returns 401" $ do
req <-
testDelete
"/api/item/"
"627d7ba92b05a76be3000003"
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
testGet
"/api/items"
[("session", Just "35bfb9c2-9ad2-4fe5-fake-99d63b8dcdcd")]
res <- httpLBS req
getResponseStatus res `shouldBe` ok200
getResponseStatus res `shouldBe` unauthorized401
describe "delete item" $ do
it "returns 401 with invalid session and item ID" $ do
req <-
testDelete
"/api/item/"
"627d7ba92b05a76be3000003"
[("session", Just "35bfb9c2-9ad2-fake-adda-99d63b8dcdcd")]
res <- httpLBS req
getResponseStatus res `shouldBe` unauthorized401
it "returns 403 when item ID doesn't belong to session" $ do
req <-
testDelete
"/api/item/"
"627d7ba92b05a76be3000003"
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
res <- httpLBS req
getResponseStatus res `shouldBe` forbidden403
it "succeeds with valid session and item ID" $ do
req <-
testDelete
"/api/item/"
"627d7ba92b05a76be3000013"
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
res <- httpLBS req
getResponseStatus res `shouldBe` ok200
describe "WooCommerce endpoints" $ do
it "generate token" $ do
it "generate token with invalid session gives 401" $ do
req <-
testPost
"/api/wootoken"
[ ("ownerid", Just "627ad3492b05a76be3000001")
, ("session", Just "35bfb9c2-9ad2-fake-adda-99d63b8dcdcd")
]
res <- httpLBS req
getResponseStatus res `shouldBe` unauthorized401
it "generate token with mismatched session gives 403" $ do
req <-
testPost
"/api/wootoken"
[ ("ownerid", Just "627ad3492b05a76be3000001")
, ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dfake")
]
res <- httpLBS req
getResponseStatus res `shouldBe` forbidden403
it "generate token with valid session succeeds" $ do
req <-
testPost
"/api/wootoken"
@ -394,6 +595,20 @@ main = do
]
res <- httpLBS req
getResponseStatus res `shouldBe` accepted202
it "read token gives 401 with bad session" $ do
req <-
testGet
"/api/wootoken"
[("session", Just "35bfb9c2-9ad2-4fe5-fake-99d63b8dcdcd")]
res <- httpLBS req
getResponseStatus res `shouldBe` unauthorized401
it "read token succeeds with valid session" $ do
req <-
testGet
"/api/wootoken"
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
res <- httpJSON req
getResponseStatus (res :: Response A.Value) `shouldBe` ok200
it "authenticate with incorrect owner" $ do
req <-
testPublicGet
@ -417,13 +632,17 @@ main = do
res <- httpJSON req
getResponseStatus (res :: Response A.Value) `shouldBe` accepted202
it "authenticate with correct token" $ do
req1 <-
testGet
"/api/wootoken"
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
res1 <- httpJSON req1
let tk = getResponseBody (res1 :: Response WooToken)
req <-
testPublicGet
"/auth"
[ ("ownerid", Just "627ad3492b05a76be3000001")
, ( "token"
, Just
"0c1702c16c7bd7e075b8bb129b24888a5cc2181fa1eb4ce9190cfcb625ecf0ee")
, ("token", Just $ (E.encodeUtf8 . w_token) tk)
, ("siteurl", Just "aHR0cHM6Ly93d3cudGVjcHJvdmFsLmNvbS8")
]
res <- httpJSON req
@ -441,13 +660,17 @@ main = do
res <- httpJSON req
getResponseStatus (res :: Response A.Value) `shouldBe` accepted202
it "request order creation" $ do
req1 <-
testGet
"/api/wootoken"
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
res1 <- httpJSON req1
let tk = getResponseBody (res1 :: Response WooToken)
req <-
testPublicGet
"/woopayment"
[ ("ownerid", Just "627ad3492b05a76be3000001")
, ( "token"
, Just
"0c1702c16c7bd7e075b8bb129b24888a5cc2181fa1eb4ce9190cfcb625ecf0ee")
, ("token", Just $ (E.encodeUtf8 . w_token) tk)
, ("siteurl", Just "aHR0cHM6Ly93d3cudGVjcHJvdmFsLmNvbS8")
, ("order_id", Just "1234")
, ("currency", Just "usd")
@ -498,6 +721,63 @@ main = do
]
res <- httpLBS req
getResponseStatus res `shouldBe` noContent204
describe "Viewing Key endpoint" $ do
let vk0 =
"zxviews1qwrw0jlxqqqqpqr9faepwqpgj09f0ee55mfwl60eumv6duk5pwncntweah0xdlhqrwre2fgmgersah9atx92z6pmxec8t32mpz59t47yuplkcdcaw3873aalv7e59xhwv846g9q9qjy0ypc68ceypg6pux490dr4snsc4m482l57rvnzj2lsh4f3dv6mltc75z72pypkx0dchwpumdwfuajstfhwulv30kjt5l0x7juwe523ufwz2xleplxf37gk2pfh59gmdjr4zsql4ga9p"
let vk1 =
"zxviews1qdjagrrpqqqqpq8es75mlu6rref0qyrstchf8dxzeygtsejwfqu8ckhwl2qj5m8am7lmupxk3vkvdjm8pawjpmesjfapvsqw96pa46c2z0kk7letrxf7mkltwz54fwpxc7kc79mm5kce3rwn5ssl009zwsra2spppwgrx25s9k5hq65f69l4jz2tjmqgy0pl49qmtaj3nudk6wglwe2hpa327hydlchtyq9av6wjd6hu68e04ahwk9a9n2kt0kj3nj99nue65awtu5cwwcpjs"
let vk2 =
"zxviews1qdjagrrpqqqqpq8es75mlufakef0qyrstchf8dxzeygtsejwfqu8ckhwl2qj5m8am7lmupxk3vkvdjm8pawjpmesjfapvsqw96pa46c2z0kk7letrxf7mkltwz54fwpxc7kc79mm5kce3rwn5ssl009zwsra2spppwgrx25s9k5hq65f69l4jz2tjmqgy0pl49qmtaj3nudk6wglwe2hpa327hydlchtyq9av6wjd6hu68e04ahwk9a9n2kt0kj3nj99nue65awtu5cwwcpjs"
it "returns 401 with bad session" $ do
req <-
testPostJson "/api/ownervk" $
A.object ["payload" A..= (vk0 :: String)]
res <-
httpLBS $
setRequestQueryString
[("session", Just "35bfb9c2-9ad2-4fe5-fake-99d63b8dcdcd")]
req
getResponseStatus res `shouldBe` unauthorized401
it "returns 403 with mismatched session" $ do
req <-
testPostJson "/api/ownervk" $
A.object ["payload" A..= (vk0 :: String)]
res <-
httpLBS $
setRequestQueryString
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
req
getResponseStatus res `shouldBe` forbidden403
it "returns 400 with malformed key" $ do
req <-
testPostJson "/api/ownervk" $
A.object ["payload" A..= (vk2 :: String)]
res <-
httpLBS $
setRequestQueryString
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
req
getResponseStatus res `shouldBe` badRequest400
it "returns 400 with non-key valid bech32" $ do
req <-
testPostJson "/api/ownervk" $
A.object ["payload" A..= ("bech321qqqsyrhqy2a" :: String)]
res <-
httpLBS $
setRequestQueryString
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
req
getResponseStatus res `shouldBe` badRequest400
it "succeeds with correct key" $ do
req <-
testPostJson "/api/ownervk" $
A.object ["payload" A..= (vk1 :: String)]
res <-
httpLBS $
setRequestQueryString
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
req
getResponseStatus res `shouldBe` created201
around handleDb $
describe "Database actions" $ do
describe "authentication" $ do
@ -512,7 +792,7 @@ main = do
doc <-
access p master "test" $
findProSession
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
"zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4"
doc `shouldNotBe` Nothing
it "upsert to DB" $ const pending
describe "Zcash prices" $ do
@ -573,7 +853,7 @@ main = do
let myOrder =
ZGoOrder
(Just (read "627ab3ea2b05a76be3000001"))
"Zaddy"
"zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4"
"35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd"
myTs
False
@ -585,6 +865,7 @@ main = do
False
""
""
"testToken1234"
let ordTest = val myOrder
case ordTest of
Doc oT -> access p master "test" (insert_ "orders" oT)
@ -600,25 +881,26 @@ main = do
Just o2 -> qpaid o2 `shouldBe` True
describe "Xero data" $ do
it "token is saved" $ \p -> do
let myToken =
XeroToken
Nothing
"Zaddy"
"superFakeToken123"
1800
"anotherSuperFakeToken"
(UTCTime (fromGregorian 2022 9 16) (secondsToDiffTime 0))
(UTCTime (fromGregorian 2022 9 16) (secondsToDiffTime 0))
""
_ <- access p master "test" $ upsertToken myToken
t <- access p master "test" $ findToken "Zaddy"
t <-
access p master "test" $
findToken
"zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4"
let t1 = (cast' . Doc) =<< t
case t1 of
Nothing -> True `shouldBe` False
Just t2 -> t_address t2 `shouldBe` "Zaddy"
Just t2 ->
t_address t2 `shouldBe`
"zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4"
it "code is saved" $ \p -> do
_ <- access p master "test" $ addAccCode "Zaddy" "ZEC"
t <- access p master "test" $ findToken "Zaddy"
_ <-
access p master "test" $
addAccCode
"zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4"
"ZEC"
t <-
access p master "test" $
findToken
"zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4"
let t1 = (cast' . Doc) =<< t
case t1 of
Nothing -> True `shouldBe` False
@ -650,7 +932,7 @@ main = do
let myUser =
User
(Just (read "6272a90f2b05a74cf1000002" :: ObjectId))
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
"zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4"
"35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcb"
1613487
"1234567"
@ -692,13 +974,13 @@ main = do
findOne
(select
[ "address" =:
("zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" :: T.Text)
("zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" :: T.Text)
]
"owners")
let s = (cast' . Doc) =<< t
let ownerPaid = maybe False opaid s
ownerPaid `shouldBe` True
_ -> True `shouldBe` False `debug` "Failed parsing payment"
_ -> True `shouldBe` False --`debug` "Failed parsing payment"
xit "owners are expired" $ \p -> do
_ <- expireOwners p "test"
now <- getCurrentTime
@ -717,7 +999,7 @@ main = do
let myTx =
ZGoTx
Nothing
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
"zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4"
"35bfb9c2-9ad2-4fe5-adda-99d63b8dcdca"
3
1613487
@ -800,6 +1082,23 @@ testDelete endpoint par body = do
setRequestPath (B.append endpoint par) defaultRequest
return testRequest
testMemoParser :: T.Text -> T.Text -> T.Text -> Property
testMemoParser t1 t2 t3 =
monadicIO $ do
let res =
runParser pZGoMemo "Parser test" $
t1 <>
" zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e " <>
t2 <> " ZGO::5d3d4494-51c0-432d-8495-050419957aea " <> t3
case res of
Left e -> assert False `debug` errorBundlePretty e
Right zm ->
assert $
U.fromString "5d3d4494-51c0-432d-8495-050419957aea" == m_session zm &&
Just
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" ==
m_address zm
testOwnerAdd :: Owner -> Property
testOwnerAdd o =
monadicIO $ do
@ -848,6 +1147,14 @@ closeDbConnection = close
handleDb :: (Pipe -> Expectation) -> IO ()
handleDb = bracket openDbConnection closeDbConnection
filterDocs :: Value -> Bool
filterDocs (Doc v) = True
filterDocs _ = False
unwrapDoc :: Value -> Document
unwrapDoc (Doc v) = v
unwrapDoc _ = []
startAPI :: Config -> IO ()
startAPI config = do
putStrLn "Starting test server ..."
@ -860,54 +1167,39 @@ startAPI config = do
_ <- access pipe master "test" (Database.MongoDB.delete (select [] "users"))
_ <- access pipe master "test" (Database.MongoDB.delete (select [] "items"))
_ <- access pipe master "test" (Database.MongoDB.delete (select [] "orders"))
_ <-
access pipe master "test" (Database.MongoDB.delete (select [] "xerotokens"))
let myUser =
User
(Just (read "6272a90f2b05a74cf1000001" :: ObjectId))
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
"zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4"
"35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd"
1613487
"8ea140fbb30615d6cae383c4f62f3ad9afb10b804f63138d5b53990bd56e0162"
False
_ <-
access
pipe
master
"test"
(insert_
"users"
[ "address" =: uaddress myUser
, "_id" =: u_id myUser
, "session" =: usession myUser
, "blocktime" =: ublocktime myUser
, "pin" =: upin myUser
, "validated" =: uvalidated myUser
])
let myUser1 =
User
(Just (read "6272a90f2b05a74cf1000003" :: ObjectId))
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
"35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd"
"zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4"
"35bfb9c2-9ad2-4fe5-adda-99d63b8dcdaa"
1613487
"8ea140fbb30615d6cae383c4f62f3ad9afb10b804f63138d5b53990bd56e0162"
True
_ <-
access
pipe
master
"test"
(insert_
"users"
[ "address" =: uaddress myUser1
, "_id" =: u_id myUser1
, "session" =: usession myUser1
, "blocktime" =: ublocktime myUser1
, "pin" =: upin myUser1
, "validated" =: uvalidated myUser1
])
let myUser2 =
User
(Just (read "6272a90f2b05a74cf1000005" :: ObjectId))
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3fake"
"35bfb9c2-9ad2-4fe5-adda-99d63b8dfake"
1613487
"8ea140fbb30615d6cae383c4f62f3ad9afb10b804f63138d5b53990bd56e0162"
True
let userList =
map unwrapDoc $ filter filterDocs $ val <$> [myUser, myUser1, myUser2]
_ <- access pipe master "test" (insertAll_ "users" userList)
let myOwner =
Owner
(Just (read "627ad3492b05a76be3000001"))
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
"zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4"
"Test shop"
"usd"
False
@ -931,17 +1223,48 @@ startAPI config = do
False
""
""
let myOwner1 =
Owner
(Just (read "627ad3492b05a76be3000008"))
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3fake"
"Test shop 2"
"usd"
False
0
False
0
"Roxy"
"Foo"
"roxy@zgo.cash"
"1 Main St"
"Mpls"
"Minnesota"
"55401"
""
"missyfoo.io"
"United States"
True
False
False
(UTCTime (fromGregorian 2023 8 6) (secondsToDiffTime 0))
False
""
""
_ <- access pipe master "test" (Database.MongoDB.delete (select [] "owners"))
let o = val myOwner
case o of
Doc d -> access pipe master "test" (insert_ "owners" d)
_ -> fail "Couldn't save Owner in DB"
let o1 = val myOwner1
case o1 of
Doc d1 -> access pipe master "test" (insert_ "owners" d1)
_ -> fail "Couldn't save Owner1 in DB"
_ <- access pipe master "test" (Database.MongoDB.delete (select [] "orders"))
myTs <- liftIO getCurrentTime
let myOrder =
ZGoOrder
(Just (read "627ab3ea2b05a76be3000000"))
"Zaddy"
"zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4"
"35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd"
myTs
False
@ -953,6 +1276,7 @@ startAPI config = do
False
""
""
"testToken1234"
let ordTest = val myOrder
case ordTest of
Doc oT -> access pipe master "test" (insert_ "orders" oT)
@ -971,13 +1295,24 @@ startAPI config = do
let proSession1 =
ZGoProSession
Nothing
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
"zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4"
myTs
False
let proSessionTest = val proSession1
case proSessionTest of
Doc pS1 -> access pipe master "test" (insert_ "prosessions" pS1)
_ -> fail "Couldn't save test ZGoProSession in DB"
let myToken =
XeroToken
Nothing
"zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4"
"superFakeToken123"
1800
"anotherSuperFakeToken"
(UTCTime (fromGregorian 2022 9 16) (secondsToDiffTime 0))
(UTCTime (fromGregorian 2022 9 16) (secondsToDiffTime 0))
""
_ <- access pipe master "test" $ upsertToken myToken
--let myWooToken =
--WooToken
--Nothing
@ -1006,7 +1341,8 @@ instance Arbitrary ZGoOrder where
l <- arbitrary
pd <- arbitrary
eI <- arbitrary
ZGoOrder i a s ts c cur p t tZ l pd eI <$> arbitrary
sc <- arbitrary
ZGoOrder i a s ts c cur p t tZ l pd eI sc <$> arbitrary
instance Arbitrary LineItem where
arbitrary = do

6
zgo-backend.cabal
View File

@ -5,7 +5,7 @@ cabal-version: 1.12
-- see: https://github.com/sol/hpack
name: zgo-backend
version: 1.5.0
version: 1.6.0
synopsis: Haskell Back-end for the ZGo point-of-sale application
description: Please see the README at <https://git.vergara.tech/Vergara_Tech//zgo-backend#readme>
category: Web
@ -78,6 +78,7 @@ library
, wai-cors
, wai-extra
, warp-tls
, zcash-haskell
default-language: Haskell2010
executable zgo-backend-exe
@ -175,10 +176,13 @@ test-suite zgo-backend-test
, hspec-wai
, http-conduit
, http-types
, megaparsec
, mongoDB
, scotty
, securemem
, text
, time
, uuid
, zcash-haskell
, zgo-backend
default-language: Haskell2010

1
zgo.cfg
View File

@ -6,6 +6,7 @@ dbUser = "zgo"
dbPassword = "zcashrules"
nodeUser = "zecwallet"
nodePassword = "rdsxlun6v4a"
confirmations = 100
port = 3000
tls = false
certificate = "/path/to/cert.pem"

1
zgotest.cfg
View File

@ -6,6 +6,7 @@ dbUser = "zgo"
dbPassword = "zcashrules"
nodeUser = "zecwallet"
nodePassword = "rdsxlun6v4a"
confirmations = 100
port = 3000
tls = false
certificate = "/path/to/cert.pem"