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

Compare commits

base: Vergara_Tech:ea731df20d38199c7d3f88423ba18b193c1d64d3
Branches Tags
Vergara_Tech:master
Vergara_Tech:rvv001
Vergara_Tech:rav001
Vergara_Tech:debug
Vergara_Tech:dev
Vergara_Tech:1.8.1
Vergara_Tech:1.8.0
Vergara_Tech:1.7.0
Vergara_Tech:1.5.0
Vergara_Tech:1.4.1
Vergara_Tech:1.4.0
Vergara_Tech:1.3.0
Vergara_Tech:1.2.5
Vergara_Tech:1.2.4
Vergara_Tech:1.2.3
Vergara_Tech:1.2.2
Vergara_Tech:1.2.1
Vergara_Tech:1.2.0
Vergara_Tech:1.1.1
Vergara_Tech:1.1.0
Vergara_Tech:1.0.0
Vergara_Tech:0.1.0.2
Vergara_Tech:0.1.0.1
Vergara_Tech:0.1.0.0
..
compare: Vergara_Tech:a8d4329e7d5b860facbd95b2d6e329985f72c4fb
Branches Tags
Vergara_Tech:rvv001
Vergara_Tech:rav001
Vergara_Tech:debug
Vergara_Tech:master
Vergara_Tech:dev
Vergara_Tech:1.8.1
Vergara_Tech:1.8.0
Vergara_Tech:1.7.0
Vergara_Tech:1.5.0
Vergara_Tech:1.4.1
Vergara_Tech:1.4.0
Vergara_Tech:1.3.0
Vergara_Tech:1.2.5
Vergara_Tech:1.2.4
Vergara_Tech:1.2.3
Vergara_Tech:1.2.2
Vergara_Tech:1.2.1
Vergara_Tech:1.2.0
Vergara_Tech:1.1.1
Vergara_Tech:1.1.0
Vergara_Tech:1.0.0
Vergara_Tech:0.1.0.2
Vergara_Tech:0.1.0.1
Vergara_Tech:0.1.0.0

No commits in common. "ea731df20d38199c7d3f88423ba18b193c1d64d3" and "a8d4329e7d5b860facbd95b2d6e329985f72c4fb" have entirely different histories.
ea731df20d ... a8d4329e7d

18 changed files with 432 additions and 1301 deletions
Show stats Expand all files Collapse all files

34
CHANGELOG.md
View file

@ -4,39 +4,7 @@ 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.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
## [1.5.0]
### Added

3
README.md
View file

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

6
package.yaml
View file

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

3
src/Config.hs
View file

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

4
src/Item.hs
View file

@ -12,7 +12,6 @@ import Data.Time.Clock
import Database.MongoDB
import GHC.Generics
import Test.QuickCheck
import User
-- | Type to represent a ZGo item
data Item =
@ -88,9 +87,6 @@ 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,12 +29,11 @@ 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 tk) =
toJSON (ZGoOrder i a s ts c cur p t tZ l paid eI sC) =
case i of
Just oid ->
object
@ -51,7 +50,6 @@ instance ToJSON ZGoOrder where
, "paid" .= paid
, "externalInvoice" .= eI
, "shortCode" .= sC
, "token" .= tk
]
Nothing ->
object
@ -68,7 +66,6 @@ instance ToJSON ZGoOrder where
, "paid" .= paid
, "externalInvoice" .= eI
, "shortCode" .= sC
, "token" .= tk
]
instance FromJSON ZGoOrder where
@ -87,7 +84,6 @@ instance FromJSON ZGoOrder where
pd <- obj .: "paid"
eI <- obj .: "externalInvoice"
sC <- obj .: "shortCode"
tk <- obj .: "token"
pure $
ZGoOrder
(if not (null i)
@ -105,10 +101,9 @@ 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 tk) =
val (ZGoOrder i a s ts c cur p t tZ l pd eI sC) =
if isJust i
then Doc
[ "_id" =: i
@ -124,7 +119,6 @@ instance Val ZGoOrder where
, "paid" =: pd
, "externalInvoice" =: eI
, "shortCode" =: sC
, "token" =: tk
]
else Doc
[ "address" =: a
@ -139,7 +133,6 @@ instance Val ZGoOrder where
, "paid" =: pd
, "externalInvoice" =: eI
, "shortCode" =: sC
, "token" =: tk
]
cast' (Doc d) = do
i <- B.lookup "_id" d
@ -155,8 +148,7 @@ instance Val ZGoOrder where
pd <- B.lookup "paid" d
eI <- B.lookup "externalInvoice" d
sC <- B.lookup "shortCode" d
tk <- B.lookup "token" d
Just (ZGoOrder i a s ts c cur p t tZ l pd eI sC tk)
Just (ZGoOrder i a s ts c cur p t tZ l pd eI sC)
cast' _ = Nothing
-- Type to represent an order line item
@ -232,17 +224,12 @@ 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,12 +366,8 @@ instance ToJSON OwnerSettings where
, "expiration" .= e
, "payconf" .= pc
, "crmToken" .= cT
, "viewkey" .= keyObfuscate vK
, "viewkey" .= (T.take 8 vK <> "...." <> T.takeEnd 8 vK)
]
where
keyObfuscate s
| s == "" = ""
| otherwise = T.take 8 s <> "...." <> T.takeEnd 8 s
-- Helper Functions
getOwnerSettings :: Owner -> OwnerSettings
@ -411,10 +407,6 @@ 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 =
@ -445,10 +437,6 @@ 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,36 +69,6 @@ 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
@ -114,9 +84,6 @@ 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,29 +28,6 @@ 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
@ -70,11 +47,8 @@ instance Val WooToken where
cast' _ = Nothing
-- Database actions
findWooToken :: Maybe ObjectId -> Action IO (Maybe Document)
findWooToken oid =
case oid of
Nothing -> return Nothing
Just o -> findOne (select ["owner" =: o] "wootokens")
findWooToken :: ObjectId -> Action IO (Maybe Document)
findWooToken oid = findOne (select ["owner" =: oid] "wootokens")
addUrl :: WooToken -> T.Text -> Action IO ()
addUrl t u =
@ -89,9 +63,8 @@ payWooOrder ::
-> BS.ByteString -- Total ZEC for order
-> IO ()
payWooOrder u i o t p z = do
wooReq <- parseRequest u
wooReq <- parseRequest $ u ++ "/wc-api/zpmtcallback"
let req =
setRequestPath "/wp-json/wc/v3/zgocallback" $
setRequestQueryString
[ ("token", Just t)
, ("orderid", Just o)
@ -104,15 +77,23 @@ payWooOrder u i o t p z = do
res <- httpLBS req
if getResponseStatus res == ok200
then return ()
else do
print $ getResponseStatus res
error "Failed to report payment to WooCommerce"
else error "Failed to report payment to WooCommerce"
generateWooToken :: Owner -> String -> Action IO ()
generateWooToken o s =
generateWooToken :: Owner -> Action IO ()
generateWooToken o =
case o_id o of
Just ownerid -> do
let wooToken = val $ WooToken Nothing ownerid (T.pack s) Nothing
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
case wooToken of
Doc wT -> insert_ "wootokens" wT
_ -> error "Couldn't create the WooCommerce token"

21
src/Xero.hs
View file

@ -171,26 +171,6 @@ 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
@ -463,6 +443,5 @@ 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"

818
src/ZGoBackend.hs
View file

@ -12,8 +12,6 @@ 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
@ -39,7 +37,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 hiding (Order)
import Database.MongoDB
import Debug.Trace
import GHC.Generics
import Item
@ -66,9 +64,6 @@ 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
@ -591,7 +586,7 @@ routes pipe config = do
simpleCorsResourcePolicy
{ corsRequestHeaders = ["Authorization", "Content-Type"]
, corsMethods = "DELETE" : simpleMethods
, corsOrigins = Nothing
--, corsOrigins = Nothing
}
middleware $
basicAuth
@ -628,288 +623,102 @@ routes pipe config = do
])
get "/api/xerotoken" $ do
code <- param "code"
session <- param "session"
user <- liftAndCatchIO $ run (findUser session)
address <- param "address"
xeroConfig <- liftAndCatchIO $ run findXero
case cast' . Doc =<< xeroConfig of
case xeroConfig of
Nothing -> status noContent204
Just c -> do
case cast' . Doc =<< user of
Nothing -> status unauthorized401
Just u -> do
Just x -> do
let xConfig = cast' (Doc x)
case xConfig of
Nothing -> status noContent204
Just c -> do
res <-
liftAndCatchIO $
requestXeroToken pipe (c_dbName config) c code $ uaddress u
requestXeroToken pipe (c_dbName config) c code address
if res
then status ok200
else status noContent204
post "/invdata" $ do
invData <- jsonData
get "/api/invdata" $ do
inv <- param "inv"
oAddress <- param "address"
xeroConfig <- liftAndCatchIO $ run findXero
let invReq = payload (invData :: Payload XeroInvoiceRequest)
case cast' . Doc =<< xeroConfig of
case xeroConfig of
Nothing -> do
status noContent204
text "Xero App credentials not found"
Just x -> do
let xConfig = cast' (Doc x)
case xConfig of
Nothing -> do
status noContent204
text "Xero App credentials corrupted"
Just c -> do
res <-
liftAndCatchIO $
requestXeroToken pipe (c_dbName config) c "none" oAddress
if res
then do
resInv <-
liftAndCatchIO $
getXeroInvoice pipe (c_dbName config) inv oAddress
case resInv of
Nothing -> do
status noContent204
text "Xero invoice not found"
Just xI -> do
status ok200
Web.Scotty.json (object ["invdata" .= toJSON xI])
else status noContent204
-- 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
[ "reportType" .= (1 :: Integer)
, "order" .= (Nothing :: Maybe ZGoOrder)
, "shop" .= (Nothing :: Maybe String)
[ "message" .= ("Xero account code found" :: String)
, "code" .= t_code c1
])
Just c -> do
o <- liftAndCatchIO $ run $ findOwnerById $ xr_owner invReq
case cast' . Doc =<< o of
Nothing -> do
status ok200
Web.Scotty.json
(object
[ "reportType" .= (2 :: Integer)
, "order" .= (Nothing :: Maybe ZGoOrder)
, "shop" .= (Nothing :: Maybe String)
])
Just o' -> do
existingOrder <-
liftAndCatchIO $
run $
findXeroOrder
(oaddress o')
(xr_invNo invReq)
(xr_shortCode invReq)
case cast' . Doc =<< existingOrder of
Nothing -> do
res <-
liftAndCatchIO $
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
[ "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
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
session <- param "session"
oAdd <- param "address"
c <- param "code"
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
liftAndCatchIO $ run (addAccCode oAdd c)
status accepted202
-- Get the WooCommerce token
get "/api/wootoken" $ do
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
])
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
])
post "/api/wootoken" $ do
oid <- param "ownerid"
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
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
-- Authenticate the WooCommerce plugin
get "/auth" $ do
oid <- param "ownerid"
t <- param "token"
siteurl <- param "siteurl"
res <- liftAndCatchIO $ run (findWooToken $ Just (read oid))
res <- liftAndCatchIO $ run (findWooToken (read oid))
let c1 = cast' . Doc =<< res
case c1 of
Nothing -> do
@ -918,7 +727,7 @@ routes pipe config = do
(object
["authorized" .= False, "message" .= ("Owner not found" :: String)])
Just c ->
if blk3Hash t == blk3Hash (T.unpack $ w_token c)
if t == w_token c
then if isNothing (w_url c)
then do
liftAndCatchIO $ run (addUrl c siteurl)
@ -956,10 +765,6 @@ 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"
@ -969,7 +774,7 @@ routes pipe config = do
amount <- param "amount"
sUrl <- param "siteurl"
orderKey <- param "orderkey"
res <- liftAndCatchIO $ run (findWooToken $ Just (read oid))
res <- liftAndCatchIO $ run (findWooToken (read oid))
let c = cast' . Doc =<< res
case c of
Nothing -> do
@ -1001,7 +806,6 @@ routes pipe config = do
Just o ->
if opaid o
then do
tk <- liftIO generateToken
let newOrder =
ZGoOrder
Nothing
@ -1028,11 +832,9 @@ 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, "token" .= tk])
Web.Scotty.json (object ["order" .= show newId])
else do
status accepted202
Web.Scotty.json
@ -1091,20 +893,12 @@ 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
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
liftAndCatchIO $ run (deleteUser userId)
status ok200
else status noContent204
--Get current blockheight from Zcash node
get "/blockheight" $ do
blockInfo <-
@ -1135,7 +929,7 @@ routes pipe config = do
[ "message" .= ("Owner found!" :: String)
, "owner" .= getOwnerSettings o
])
get "/ownerid" $ do
get "/api/ownerid" $ do
id <- param "id"
owner <- liftAndCatchIO $ run (findOwnerById id)
case owner of
@ -1149,7 +943,23 @@ routes pipe config = do
Web.Scotty.json
(object
[ "message" .= ("Owner found!" :: String)
, "owner" .= getOwnerSettings q
, "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
]
])
--Upsert owner to DB
post "/api/owner" $ do
@ -1205,99 +1015,33 @@ 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
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
])
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])
--Upsert item
post "/api/item" $ do
i <- jsonData
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
let q = payload (i :: Payload Item)
_ <- liftAndCatchIO $ run (upsertItem q)
status created201
--Delete item
Web.Scotty.delete "/api/item/:id" $ do
session <- param "session"
oId <- param "id"
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
let r = mkRegex "^[a-f0-9]{24}$"
if matchTest r oId
then do
liftAndCatchIO $ run (deleteItem oId)
status ok200
else status noContent204
--Get price for Zcash
get "/price" $ do
curr <- param "currency"
@ -1313,48 +1057,39 @@ routes pipe config = do
])
--Get all closed orders for the address
get "/api/allorders" $ do
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
])
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
])
--Get order by id for receipts
get "/order/:id" $ do
get "/api/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 cast' . Doc =<< myOrder of
case myOrder of
Nothing -> 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
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
--Get order by session
get "/api/order" $ do
sess <- param "session"
@ -1397,37 +1132,13 @@ routes pipe config = do
post "/api/order" $ do
newOrder <- jsonData
let q = payload (newOrder :: Payload ZGoOrder)
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
_ <- liftAndCatchIO $ run (upsertOrder q)
status created201
--Delete order
Web.Scotty.delete "/api/order/:id" $ do
oId <- param "id"
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
liftAndCatchIO $ run (deleteOrder oId)
status ok200
-- Get language for component
get "/getmainlang" $ do
lang <- param "lang"
@ -1453,22 +1164,6 @@ 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"
@ -1556,10 +1251,36 @@ 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 :: Integer -> Text.Regex.Regex -> ZcashTx -> Bool
isRelevant conf re t
| zconfirmations t < conf && (matchTest re . T.unpack . zmemo) t = True
isRelevant :: Text.Regex.Regex -> ZcashTx -> Bool
isRelevant re t
| zconfirmations t < 100 && (matchTest re . T.unpack . zmemo) t = True
| otherwise = False
-- | New function to scan transactions with parser
@ -1575,103 +1296,85 @@ scanZcash' config pipe = do
-- | Function to scan loaded viewing keys for payments
scanPayments :: Config -> Pipe -> IO ()
scanPayments config pipe = do
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
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"
-- | RPC methods
-- | List addresses with viewing keys loaded
@ -1834,17 +1537,4 @@ 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,6 +119,7 @@ type Parser = Parsec Void T.Text
pSession :: Parser MemoToken
pSession = do
optional spaceChar
string "ZGO"
pay <- optional $ char 'p'
string "::"
@ -141,18 +142,13 @@ pSaplingAddress = do
pMsg :: Parser MemoToken
pMsg = do
msg <-
some
(alphaNumChar <|> punctuationChar <|> symbolChar <|>
charCategory OtherSymbol)
pure $ Msg . T.pack $ msg
Msg . T.pack <$>
some (alphaNumChar <|> punctuationChar <|> charCategory OtherSymbol)
pMemo :: Parser MemoToken
pMemo = do
optional $ some spaceChar
t <- pSession <|> pSaplingAddress <|> pMsg
optional $ some spaceChar
return t
optional spaceChar
pSession <|> pSaplingAddress <|> pMsg
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.23
resolver: lts-20.19
#url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/4.yaml
# User packages to be built.
@ -44,16 +44,6 @@ 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,67 +15,6 @@ 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:
@ -92,7 +31,7 @@ packages:
hackage: crypto-rng-0.3.0.1@sha256:04f4ae75943ecad8b794950985054130f272d65a588b6b6528f56df0bfedc4dc,1565
snapshots:
- completed:
sha256: 4c972e067bae16b95961dbfdd12e07f1ee6c8fffabbfa05c3d65100b03f548b7
size: 650253
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/23.yaml
original: lts-20.23
sha256: 42f77c84b34f68c30c2cd0bf8c349f617a0f428264362426290847a6a2019b64
size: 649618
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/19.yaml
original: lts-20.19

622
test/Spec.hs
View file

@ -13,12 +13,10 @@ 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
@ -34,7 +32,6 @@ 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
@ -56,31 +53,7 @@ main = do
describe "hex strings" $ do
prop "encoding and decoding are inverse" $ \x ->
(decodeHexText . encodeHexText) x == x
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"
describe "zToZGoTx" $ do
it "converts ZecWallet tx to ZGo tx" $ do
let t =
ZcashTx
@ -183,13 +156,32 @@ main = do
getResponseStatus res `shouldBe` accepted202
describe "Price endpoint" $ do
it "returns a price for an existing currency" $ do
req <- testGet "/price" [("currency", Just "usd")]
req <-
testGet
"/api/price"
[ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
, ("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 "/price" [("currency", Just "jpy")]
req <-
testGet
"/api/price"
[ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
, ("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 <-
@ -209,7 +201,7 @@ main = do
it "returns a block number" $ do
req <-
testGet
"/blockheight"
"/api/blockheight"
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
res <- httpJSON req
height (getResponseBody (res :: Response Block)) `shouldSatisfy` \x ->
@ -233,32 +225,18 @@ main = do
req <-
testGet
"/api/xeroaccount"
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
[ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
, ("address", Just "Zaddy")
]
res <- httpJSON req
getResponseStatus (res :: Response A.Value) `shouldBe` ok200
it "reading returns 401 with invalid session" $ do
it "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 <-
@ -274,39 +252,14 @@ main = do
[("session", Just "suchafak-euui-dican-eve-nbelieveitca")]
res <- httpLBS req
getResponseStatus res `shouldBe` unauthorized401
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
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 "Owner endpoint" $
--prop "add owner" testOwnerAdd
do
@ -341,90 +294,8 @@ main = do
]
res <- httpLBS req
getResponseStatus res `shouldBe` ok200
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
describe "Order endpoints" $ do
prop "upsert order" testOrderAdd
it "get order by session" $ do
req <-
testGet
@ -432,7 +303,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 with bad session" $ do
it "get order by session fails when invalid" $ do
req <-
testGet
"/api/order"
@ -442,49 +313,40 @@ main = do
it "get order by id" $ do
req <-
testGet
"/order/627ab3ea2b05a76be3000000"
[("token", Just "testToken1234")]
"/api/order/627ab3ea2b05a76be3000000"
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
res <- httpJSON req
getResponseStatus (res :: Response A.Value) `shouldBe` ok200
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
it "get order with wrong id" $ do
req <-
testGet
"/order/627ab3ea2b05a76be3000000"
[("token", Just "wrongToken1234")]
"/api/order/6273hrb"
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
res <- httpLBS req
getResponseStatus res `shouldBe` forbidden403
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
it "get all orders for owner" $ do
req <-
testGet
"/api/allorders"
[("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 "get all orders for owner fails with bad session" $ do
req <-
testGet
"/api/allorders"
[("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")]
[ ("address", Just "Zaddy")
, ("session", Just "35bfb9c2-9ad2-4fe5-fake-99d63b8dcdcd")
]
res <- httpLBS req
getResponseStatus res `shouldBe` unauthorized401
it "delete order by id" $ do
@ -495,98 +357,35 @@ main = do
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
res <- httpLBS req
getResponseStatus res `shouldBe` ok200
describe "Item endpoint" $ do
it "adding item with bad session fails" $ do
let item =
Item
Nothing
"Table"
"Oak"
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
499.99
it "delete order by id fails with bad session" $ do
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"
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
res <- httpJSON req
getResponseStatus (res :: Response A.Value) `shouldBe` ok200
it "get items with invalid session returns 401" $ do
req <-
testGet
"/api/items"
testDelete
"/api/order/"
"627ab3ea2b05a76be3000000"
[("session", Just "35bfb9c2-9ad2-4fe5-fake-99d63b8dcdcd")]
res <- httpLBS req
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 "Item endpoint" $ do
prop "add item" testItemAdd
it "get items" $ do
req <-
testGet
"/api/items"
[ ("address", Just "Zaddy")
, ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
]
res <- httpJSON req
getResponseStatus (res :: Response A.Value) `shouldBe` ok200
it "delete item" $ do
req <-
testDelete
"/api/item/"
"627d7ba92b05a76be3000003"
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
res <- httpLBS req
getResponseStatus res `shouldBe` ok200
describe "WooCommerce endpoints" $ 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
it "generate token" $ do
req <-
testPost
"/api/wootoken"
@ -595,20 +394,6 @@ 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
@ -632,17 +417,13 @@ 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 $ (E.encodeUtf8 . w_token) tk)
, ( "token"
, Just
"0c1702c16c7bd7e075b8bb129b24888a5cc2181fa1eb4ce9190cfcb625ecf0ee")
, ("siteurl", Just "aHR0cHM6Ly93d3cudGVjcHJvdmFsLmNvbS8")
]
res <- httpJSON req
@ -660,17 +441,13 @@ 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 $ (E.encodeUtf8 . w_token) tk)
, ( "token"
, Just
"0c1702c16c7bd7e075b8bb129b24888a5cc2181fa1eb4ce9190cfcb625ecf0ee")
, ("siteurl", Just "aHR0cHM6Ly93d3cudGVjcHJvdmFsLmNvbS8")
, ("order_id", Just "1234")
, ("currency", Just "usd")
@ -721,63 +498,6 @@ 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
@ -792,7 +512,7 @@ main = do
doc <-
access p master "test" $
findProSession
"zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4"
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
doc `shouldNotBe` Nothing
it "upsert to DB" $ const pending
describe "Zcash prices" $ do
@ -853,7 +573,7 @@ main = do
let myOrder =
ZGoOrder
(Just (read "627ab3ea2b05a76be3000001"))
"zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4"
"Zaddy"
"35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd"
myTs
False
@ -865,7 +585,6 @@ main = do
False
""
""
"testToken1234"
let ordTest = val myOrder
case ordTest of
Doc oT -> access p master "test" (insert_ "orders" oT)
@ -881,26 +600,25 @@ main = do
Just o2 -> qpaid o2 `shouldBe` True
describe "Xero data" $ do
it "token is saved" $ \p -> do
t <-
access p master "test" $
findToken
"zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4"
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"
let t1 = (cast' . Doc) =<< t
case t1 of
Nothing -> True `shouldBe` False
Just t2 ->
t_address t2 `shouldBe`
"zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4"
Just t2 -> t_address t2 `shouldBe` "Zaddy"
it "code is saved" $ \p -> do
_ <-
access p master "test" $
addAccCode
"zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4"
"ZEC"
t <-
access p master "test" $
findToken
"zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4"
_ <- access p master "test" $ addAccCode "Zaddy" "ZEC"
t <- access p master "test" $ findToken "Zaddy"
let t1 = (cast' . Doc) =<< t
case t1 of
Nothing -> True `shouldBe` False
@ -932,7 +650,7 @@ main = do
let myUser =
User
(Just (read "6272a90f2b05a74cf1000002" :: ObjectId))
"zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4"
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
"35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcb"
1613487
"1234567"
@ -974,13 +692,13 @@ main = do
findOne
(select
[ "address" =:
("zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" :: T.Text)
("zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" :: 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
@ -999,7 +717,7 @@ main = do
let myTx =
ZGoTx
Nothing
"zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4"
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
"35bfb9c2-9ad2-4fe5-adda-99d63b8dcdca"
3
1613487
@ -1082,23 +800,6 @@ 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
@ -1147,14 +848,6 @@ 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 ..."
@ -1167,39 +860,54 @@ 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))
"zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4"
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
"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))
"zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4"
"35bfb9c2-9ad2-4fe5-adda-99d63b8dcdaa"
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
"35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd"
1613487
"8ea140fbb30615d6cae383c4f62f3ad9afb10b804f63138d5b53990bd56e0162"
True
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)
_ <-
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 myOwner =
Owner
(Just (read "627ad3492b05a76be3000001"))
"zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4"
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
"Test shop"
"usd"
False
@ -1223,48 +931,17 @@ 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"))
"zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4"
"Zaddy"
"35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd"
myTs
False
@ -1276,7 +953,6 @@ startAPI config = do
False
""
""
"testToken1234"
let ordTest = val myOrder
case ordTest of
Doc oT -> access pipe master "test" (insert_ "orders" oT)
@ -1295,24 +971,13 @@ startAPI config = do
let proSession1 =
ZGoProSession
Nothing
"zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4"
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
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
@ -1341,8 +1006,7 @@ instance Arbitrary ZGoOrder where
l <- arbitrary
pd <- arbitrary
eI <- arbitrary
sc <- arbitrary
ZGoOrder i a s ts c cur p t tZ l pd eI sc <$> arbitrary
ZGoOrder i a s ts c cur p t tZ l pd eI <$> 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.6.0
version: 1.5.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,7 +78,6 @@ library
, wai-cors
, wai-extra
, warp-tls
, zcash-haskell
default-language: Haskell2010
executable zgo-backend-exe
@ -176,13 +175,10 @@ 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,7 +6,6 @@ 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,7 +6,6 @@ dbUser = "zgo"
dbPassword = "zcashrules"
nodeUser = "zecwallet"
nodePassword = "rdsxlun6v4a"
confirmations = 100
port = 3000
tls = false
certificate = "/path/to/cert.pem"