Updated version of borsh #10

Merged
pitmutt merged 7 commits from dev19 into master 2024-05-21 17:28:44 +00:00
10 changed files with 237 additions and 589 deletions

3
.gitignore vendored
View file

@ -1,2 +1,3 @@
.stack-work/
*~
dist-newstyle/
*~

4
.gitmodules vendored Normal file
View file

@ -0,0 +1,4 @@
[submodule "zcash-haskell"]
path = zcash-haskell
url = https://git.vergara.tech/Vergara_Tech/zcash-haskell
branch = milestone2

16
cabal.project Normal file
View file

@ -0,0 +1,16 @@
packages:
./*.cabal
zcash-haskell/zcash-haskell.cabal
with-compiler: ghc-9.6.5
source-repository-package
type: git
location: https://git.vergara.tech/Vergara_Tech/haskell-hexstring.git
tag: 39d8da7b11a80269454c2f134a5c834e0f3cb9a7
source-repository-package
type: git
location: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git
tag: 335e804454cd30da2c526457be37e477f71e4665

View file

@ -1,167 +0,0 @@
name: zgo-backend
version: 1.8.1
git: "https://git.vergara.tech/Vergara_Tech/zgo-backend"
license: MIT
author: "Rene Vergara"
maintainer: "rene@vergara.network"
copyright: "2022-2024 Vergara Technologies LLC"
extra-source-files:
- README.md
- CHANGELOG.md
- zgo.cfg
# Metadata used when publishing your package
synopsis: Haskell Back-end for the ZGo point-of-sale application
category: Web
# To avoid duplicated efforts in documentation and dealing with the
# complications of embedding Haddock markup inside cabal files, it is
# common to point users to the README.md file.
description: Please see the README at <https://git.vergara.tech/Vergara_Tech//zgo-backend#readme>
dependencies:
- base >= 4.7 && < 5
library:
source-dirs: src
dependencies:
- mongoDB
- time
- text
- unordered-containers
- bson
- aeson
- QuickCheck
- quickcheck-instances
- scotty
- http-conduit
- wai-extra
- http-types
- time
- securemem
- bytestring
- regex-base
- regex-compat
- array
- random
- vector
- wai-cors
- warp-tls
- hexstring
- configurator
- scientific
- jwt
- containers
- base64-bytestring
- wai
- blake3
- memory
- ghc-prim
- network
- crypto-rng
- megaparsec
- uuid
- zcash-haskell
executables:
zgo-backend-exe:
main: Server.hs
source-dirs: app
ghc-options:
- -main-is Server
- -threaded
- -rtsopts
- -with-rtsopts=-N
- -Wall
dependencies:
- zgo-backend
- base
- scotty
- wai-extra
- securemem
- text
- aeson
- mongoDB
- http-types
- http-conduit
- time
- bytestring
- configurator
- warp-tls
- warp
- megaparsec
zgo-token-refresh:
main: TokenRefresh.hs
source-dirs: app
ghc-options:
- -main-is TokenRefresh
- -threaded
- -rtsopts
- -with-rtsopts=-N
- -Wall
dependencies:
- base
- zgo-backend
- base
- scotty
- wai-extra
- securemem
- text
- aeson
- mongoDB
- http-types
- http-conduit
- time
- bytestring
- configurator
- warp-tls
- warp
- megaparsec
zgo-tasks:
main: Tasks.hs
source-dirs: app
ghc-options:
- -main-is Tasks
- -threaded
- -rtsopts
- -with-rtsopts=-N
- -Wall
dependencies:
- base
- mongoDB
- zgo-backend
- scotty
- warp-tls
- warp
- time
- megaparsec
tests:
zgo-backend-test:
main: Spec.hs
source-dirs: test
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
- -main-is Spec
dependencies:
- zgo-backend
- hspec
- QuickCheck
- text
- aeson
- http-conduit
- http-types
- hspec-expectations-json
- bytestring
- mongoDB
- hspec-wai
- securemem
- time
- configurator
- scotty
- megaparsec
- uuid
- zcash-haskell

View file

@ -62,7 +62,7 @@ import Text.Megaparsec (runParser)
import Text.Regex
import Text.Regex.Base
import User
import Web.Scotty
import Web.Scotty hiding (getResponseStatus)
import WooCommerce
import Xero
import ZGoTx
@ -91,8 +91,8 @@ instance (FromJSON r) => FromJSON (Payload r) where
-- | Type to model a (simplified) block of Zcash blockchain
data Block = Block
{ height :: Integer
, size :: Integer
{ height :: !Integer
, size :: !Integer
} deriving (Show, Generic, ToJSON)
instance FromJSON Block where
@ -101,14 +101,14 @@ instance FromJSON Block where
-- | Type to model a Zcash shielded transaction
data ZcashTx = ZcashTx
{ ztxid :: T.Text
, zamount :: Double
, zamountZat :: Integer
, zblockheight :: Integer
, zblocktime :: Integer
, zchange :: Bool
, zconfirmations :: Integer
, zmemo :: T.Text
{ ztxid :: !HexString
, zamount :: !Double
, zamountZat :: !Integer
, zblockheight :: !Integer
, zblocktime :: !Integer
, zchange :: !Bool
, zconfirmations :: !Integer
, zmemo :: !T.Text
} deriving (Show, Generic)
instance FromJSON ZcashTx where
@ -155,14 +155,14 @@ instance Arbitrary ZcashTx where
bt <- arbitrary
c <- arbitrary
cm <- arbitrary
ZcashTx a aZ t bh bt c cm <$> arbitrary
ZcashTx (HexString a) aZ t bh bt c cm <$> arbitrary
-- | A type to model an address group
data AddressGroup = AddressGroup
{ agsource :: AddressSource
, agtransparent :: [ZcashAddress]
, agsapling :: [ZcashAddress]
, agunified :: [ZcashAddress]
{ agsource :: !AddressSource
, agtransparent :: ![ZcashAddress]
, agsapling :: ![ZcashAddress]
, agunified :: ![ZcashAddress]
} deriving (Show, Generic)
instance FromJSON AddressGroup where
@ -245,10 +245,10 @@ instance FromJSON ZcashPool where
_ -> fail "Not a known Zcash pool"
data ZcashAddress = ZcashAddress
{ source :: AddressSource
, pool :: [ZcashPool]
, account :: Maybe Integer
, addy :: T.Text
{ source :: !AddressSource
, pool :: ![ZcashPool]
, account :: !(Maybe Integer)
, addy :: !T.Text
} deriving (Eq)
instance Show ZcashAddress where
@ -269,14 +269,14 @@ decodeHexText h = E.decodeUtf8With lenientDecode $ BS.pack $ hexRead h
-- | Helper function to turn a string into a hex-encoded string
encodeHexText :: T.Text -> String
encodeHexText t = T.unpack . toText . fromBytes $ E.encodeUtf8 t
encodeHexText t = T.unpack . toText . fromRawBytes $ E.encodeUtf8 t
-- Types for the ZGo database documents
-- | Type to model a country for the database's country list
data Country = Country
{ _id :: String
, name :: T.Text
, code :: T.Text
{ _id :: !String
, name :: !T.Text
, code :: !T.Text
} deriving (Eq, Show, Generic, ToJSON)
parseCountryBson :: B.Document -> Maybe Country
@ -304,24 +304,24 @@ zToZGoTx (ZcashTx t a aZ bh bt c conf m) = do
then do
let sess = T.pack (fst $ head reg ! 1)
let nAddy = T.pack (fst $ head reg ! 2)
ZGoTx Nothing nAddy sess conf bt a t m
ZGoTx Nothing nAddy sess conf bt a (toText t) m
else do
if not (null reg2)
then do
let sess = T.pack (fst $ head reg2 ! 1)
ZGoTx Nothing "" sess conf bt a t m
ZGoTx Nothing "" sess conf bt a (toText t) m
else do
if not (null reg3)
then do
let sess = T.pack (fst $ head reg3 ! 2)
let nAddy = T.pack (fst $ head reg3 ! 1)
ZGoTx Nothing nAddy sess conf bt a t m
else ZGoTx Nothing "" "" conf bt a t m
ZGoTx Nothing nAddy sess conf bt a (toText t) m
else ZGoTx Nothing "" "" conf bt a (toText t) m
zToZGoTx' :: Config -> Pipe -> ZcashTx -> IO ()
zToZGoTx' config pipe (ZcashTx t a aZ bh bt c conf m) = do
when (conf < c_confirmations config) $ do
let zM = runParser pZGoMemo (T.unpack t) m
let zM = runParser pZGoMemo (T.unpack . toText $ t) m
case zM of
Right zM' -> do
print zM'
@ -333,7 +333,7 @@ zToZGoTx' config pipe (ZcashTx t a aZ bh bt c conf m) = do
conf
bt
a
t
(toText t)
m
if m_payment zM'
then upsertPayment pipe (c_dbName config) tx
@ -342,10 +342,10 @@ zToZGoTx' config pipe (ZcashTx t a aZ bh bt c conf m) = do
-- |Type to model a price in the ZGo database
data ZGoPrice = ZGoPrice
{ _id :: String
, currency :: T.Text
, price :: Double
, timestamp :: UTCTime
{ _id :: !String
, currency :: !T.Text
, price :: !Double
, timestamp :: !UTCTime
} deriving (Eq, Show, Generic, ToJSON)
parseZGoPrice :: B.Document -> Maybe ZGoPrice
@ -408,9 +408,9 @@ sendPin nodeUser nodePwd nodeAddress addr pin = do
-- | Type for Operation Result
data OpResult = OpResult
{ opsuccess :: T.Text
, opmessage :: Maybe T.Text
, optxid :: Maybe T.Text
{ opsuccess :: !T.Text
, opmessage :: !(Maybe T.Text)
, optxid :: !(Maybe T.Text)
} deriving (Show, Eq)
instance FromJSON OpResult where
@ -469,6 +469,7 @@ addUser nodeUser nodePwd p db node (Just tx) = do
_ <- liftIO $ sendPin nodeUser nodePwd node (address tx) (T.pack newPin)
let pinHash =
BLK.hash
Nothing
[ BA.pack . BS.unpack . C.pack . T.unpack $
T.pack newPin <> session tx :: BA.Bytes
]
@ -607,19 +608,18 @@ routes pipe config = do
middleware $ zgoAuth pipe $ c_dbName config
--Get list of countries for UI
get "/api/countries" $ do
countries <- liftAndCatchIO $ run listCountries
case countries of
[] -> do
status noContent204
_ -> do
countries <- liftIO $ run listCountries
if not (null countries)
then do
Web.Scotty.json
(object
[ "message" .= ("Country data found" :: String)
, "countries" .= toJSON (map parseCountryBson countries)
])
else status noContent204
--Get Xero credentials
get "/api/xero" $ do
xeroConfig <- liftAndCatchIO $ run findXero
xeroConfig <- liftIO $ run findXero
case xeroConfig of
Nothing -> status noContent204
Just x -> do
@ -634,10 +634,10 @@ routes pipe config = do
, "xeroConfig" .= toJSON (c :: Xero)
])
get "/api/xerotoken" $ do
code <- param "code"
session <- param "session"
user <- liftAndCatchIO $ run (findUser session)
xeroConfig <- liftAndCatchIO $ run findXero
code <- queryParam "code"
session <- queryParam "session"
user <- liftIO $ run (findUser session)
xeroConfig <- liftIO $ run findXero
case cast' . Doc =<< xeroConfig of
Nothing -> status noContent204
Just c -> do
@ -645,14 +645,14 @@ routes pipe config = do
Nothing -> status unauthorized401
Just u -> do
res <-
liftAndCatchIO $
liftIO $
requestXeroToken pipe (c_dbName config) c code $ uaddress u
if res
then status ok200
else status noContent204
post "/invdata" $ do
invData <- jsonData
xeroConfig <- liftAndCatchIO $ run findXero
xeroConfig <- liftIO $ run findXero
let invReq = payload (invData :: Payload XeroInvoiceRequest)
case cast' . Doc =<< xeroConfig of
Nothing -> do
@ -664,7 +664,7 @@ routes pipe config = do
, "shop" .= (Nothing :: Maybe String)
])
Just c -> do
o <- liftAndCatchIO $ run $ findOwnerById $ xr_owner invReq
o <- liftIO $ run $ findOwnerById $ xr_owner invReq
case cast' . Doc =<< o of
Nothing -> do
status ok200
@ -676,7 +676,7 @@ routes pipe config = do
])
Just o' -> do
existingOrder <-
liftAndCatchIO $
liftIO $
run $
findXeroOrder
(oaddress o')
@ -685,12 +685,12 @@ routes pipe config = do
case cast' . Doc =<< existingOrder of
Nothing -> do
res <-
liftAndCatchIO $
liftIO $
requestXeroToken pipe (c_dbName config) c "none" $ oaddress o'
if res
then do
resInv <-
liftAndCatchIO $
liftIO $
getXeroInvoice pipe (c_dbName config) (xr_invNo invReq) $
oaddress o'
case resInv of
@ -712,7 +712,7 @@ routes pipe config = do
now <- liftIO getCurrentTime
tk <- liftIO generateToken
pr <-
liftAndCatchIO $
liftIO $
run
(findPrice $
T.unpack . ocurrency $ o')
@ -765,11 +765,11 @@ routes pipe config = do
0
0
_ <-
liftAndCatchIO $
liftIO $
run $
upsertOrder newOrder 0 0
finalOrder <-
liftAndCatchIO $
liftIO $
run $
findXeroOrder
(oaddress o')
@ -850,12 +850,12 @@ routes pipe config = do
])
-- Get the xeroaccount code
get "/api/xeroaccount" $ do
session <- param "session"
user <- liftAndCatchIO $ run (findUser session)
session <- queryParam "session"
user <- liftIO $ run (findUser session)
case cast' . Doc =<< user of
Nothing -> status unauthorized401
Just u -> do
res <- liftAndCatchIO $ run (findToken $ uaddress u)
res <- liftIO $ run (findToken $ uaddress u)
let c = cast' . Doc =<< res
case c of
Nothing -> status noContent204
@ -868,27 +868,27 @@ routes pipe config = do
])
-- Save the xeroaccount code
post "/api/xeroaccount" $ do
session <- param "session"
c <- param "code"
user <- liftAndCatchIO $ run (findUser session)
session <- queryParam "session"
c <- queryParam "code"
user <- liftIO $ run (findUser session)
case cast' . Doc =<< user of
Nothing -> status unauthorized401
Just u -> do
let oAdd = uaddress u
liftAndCatchIO $ run (addAccCode oAdd c)
liftIO $ run (addAccCode oAdd c)
status accepted202
-- Get the WooCommerce token
get "/api/wootoken" $ do
session <- param "session"
user <- liftAndCatchIO $ run (findUser session)
session <- queryParam "session"
user <- liftIO $ run (findUser session)
case cast' . Doc =<< user of
Nothing -> status unauthorized401
Just u -> do
owner <- liftAndCatchIO $ run (findOwner $ uaddress u)
owner <- liftIO $ run (findOwner $ uaddress u)
case cast' . Doc =<< owner of
Nothing -> status internalServerError500
Just o -> do
res <- liftAndCatchIO $ run (findWooToken $ o_id o)
res <- liftIO $ run (findWooToken $ o_id o)
let t1 = cast' . Doc =<< res
case t1 of
Nothing -> status noContent204
@ -901,28 +901,28 @@ routes pipe config = do
, "siteurl" .= w_url t
])
post "/api/wootoken" $ do
oid <- param "ownerid"
session <- param "session"
user <- liftAndCatchIO $ run (findUser session)
oid <- queryParam "ownerid"
session <- queryParam "session"
user <- liftIO $ run (findUser session)
case cast' . Doc =<< user of
Nothing -> status unauthorized401
Just u -> do
res <- liftAndCatchIO $ run (findOwnerById oid)
res <- liftIO $ 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)
liftIO $ 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 $ Just (read oid))
oid <- queryParam "ownerid"
t <- queryParam "token"
siteurl <- queryParam "siteurl"
res <- liftIO $ run (findWooToken $ Just (read oid))
let c1 = cast' . Doc =<< res
case c1 of
Nothing -> do
@ -934,7 +934,7 @@ routes pipe config = do
if blk3Hash t == blk3Hash (T.unpack $ w_token c)
then if isNothing (w_url c)
then do
liftAndCatchIO $ run (addUrl c siteurl)
liftIO $ run (addUrl c siteurl)
status ok200
Web.Scotty.json
(object
@ -972,18 +972,20 @@ routes pipe config = do
where blk3Hash :: String -> String
blk3Hash s =
show
(BLK.hash [BA.pack . BS.unpack . C.pack $ s :: BA.Bytes] :: BLK.Digest
(BLK.hash
Nothing
[BA.pack . BS.unpack . C.pack $ s :: BA.Bytes] :: BLK.Digest
BLK.DEFAULT_DIGEST_LEN)
get "/woopayment" $ do
oid <- param "ownerid"
t <- param "token"
ordId <- param "order_id"
date <- param "date"
curr <- param "currency"
amount <- param "amount"
sUrl <- param "siteurl"
orderKey <- param "orderkey"
res <- liftAndCatchIO $ run (findWooToken $ Just (read oid))
oid <- queryParam "ownerid"
t <- queryParam "token"
ordId <- queryParam "order_id"
date <- queryParam "date"
curr <- queryParam "currency"
amount <- queryParam "amount"
sUrl <- queryParam "siteurl"
orderKey <- queryParam "orderkey"
res <- liftIO $ run (findWooToken $ Just (read oid))
let c = cast' . Doc =<< res
case c of
Nothing -> do
@ -995,7 +997,7 @@ routes pipe config = do
(E.decodeUtf8With lenientDecode . B64.decodeLenient . C.pack) sUrl ==
fromMaybe "" (w_url x)
then do
zecPriceDb <- liftAndCatchIO (run (findPrice curr))
zecPriceDb <- liftIO (run (findPrice curr))
let zecPrice = parseZGoPrice =<< zecPriceDb
case zecPrice of
Nothing -> do
@ -1004,8 +1006,7 @@ routes pipe config = do
(object ["message" .= ("Currency not supported" :: String)])
Just zP -> do
ownerDb <-
liftAndCatchIO $
run (findOwnerById (T.pack . show $ w_owner x))
liftIO $ run (findOwnerById (T.pack . show $ w_owner x))
let owner = cast' . Doc =<< ownerDb
case owner of
Nothing -> do
@ -1046,7 +1047,7 @@ routes pipe config = do
0
0
0
newId <- liftAndCatchIO $ run (insertWooOrder newOrder)
newId <- liftIO $ run (insertWooOrder newOrder)
status ok200
Web.Scotty.json
(object ["order" .= show newId, "token" .= tk])
@ -1060,8 +1061,8 @@ routes pipe config = do
Web.Scotty.json
(object ["message" .= ("Incorrect plugin config" :: String)])
get "/checkuser" $ do
sess <- param "session"
user <- liftAndCatchIO $ run (findUser sess)
sess <- queryParam "session"
user <- liftIO $ run (findUser sess)
case parseUserBson =<< user of
Nothing -> status noContent204
Just u -> do
@ -1069,8 +1070,8 @@ routes pipe config = do
Web.Scotty.json (object ["validated" .= uvalidated u])
--Get user associated with session
get "/api/user" $ do
sess <- param "session"
user <- liftAndCatchIO $ run (findUser sess)
sess <- queryParam "session"
user <- liftIO $ run (findUser sess)
case user of
Nothing -> status noContent204
Just u -> do
@ -1082,19 +1083,20 @@ routes pipe config = do
])
--Validate user, updating record
post "/validateuser" $ do
providedPin <- param "pin"
sess <- param "session"
providedPin <- queryParam "pin"
sess <- queryParam "session"
let pinHash =
BLK.hash
Nothing
[ BA.pack . BS.unpack . C.pack . T.unpack $ providedPin <> sess :: BA.Bytes
]
user <- liftAndCatchIO $ run (findUser sess)
user <- liftIO $ run (findUser sess)
case user of
Nothing -> status noContent204 --`debug` "No user match"
Nothing -> status noContent204 `debug` "No user match"
Just u -> do
let parsedUser = parseUserBson u
case parsedUser of
Nothing -> status noContent204 --`debug` "Couldn't parse user"
Nothing -> status noContent204 `debug` "Couldn't parse user"
Just pUser -> do
let ans =
upin pUser ==
@ -1102,30 +1104,31 @@ routes pipe config = do
(pinHash :: BLK.Digest BLK.DEFAULT_DIGEST_LEN))
if ans
then do
liftAndCatchIO $ run (validateUser sess)
liftIO $ run (validateUser sess)
status accepted202
else status noContent204 --`debug` ("Pins didn't match: " ++ providedPin ++ " " ++ T.unpack (upin pUser))
else status noContent204 `debug`
("Pins didn't match: " ++
T.unpack providedPin ++ " " ++ T.unpack (upin pUser))
--Delete user
Web.Scotty.delete "/api/user/:id" $ do
userId <- param "id"
session <- param "session"
userId <- captureParam "id"
session <- queryParam "session"
let r = mkRegex "^[a-f0-9]{24}$"
if matchTest r userId
then do
u <- liftAndCatchIO $ run (findUserById userId)
u <- liftIO $ run (findUserById userId)
case cast' . Doc =<< u of
Nothing -> status badRequest400
Just u' ->
if session == usession u'
then do
liftAndCatchIO $ run (deleteUser userId)
liftIO $ run (deleteUser userId)
status ok200
else status forbidden403
else status badRequest400
--Get current blockheight from Zcash node
get "/blockheight" $ do
blockInfo <-
liftAndCatchIO $ makeZcashCall nodeUser nodePwd "getblock" ["-1"]
blockInfo <- liftIO $ makeZcashCall nodeUser nodePwd "getblock" ["-1"]
let content = getResponseBody blockInfo :: RpcResponse Block
if isNothing (err content)
then do
@ -1137,12 +1140,12 @@ routes pipe config = do
get "/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress])
--Get owner by address
get "/api/owner" $ do
session <- param "session"
user <- liftAndCatchIO $ run (findUser session)
session <- queryParam "session"
user <- liftIO $ run (findUser session)
case parseUserBson =<< user of
Nothing -> status noContent204
Just u -> do
owner <- liftAndCatchIO $ run (findOwner $ uaddress u)
owner <- liftIO $ run (findOwner $ uaddress u)
case cast' . Doc =<< owner of
Nothing -> status noContent204
Just o -> do
@ -1153,8 +1156,8 @@ routes pipe config = do
, "owner" .= getOwnerSettings o
])
get "/ownerid" $ do
id <- param "id"
owner <- liftAndCatchIO $ run (findOwnerById id)
id <- queryParam "id"
owner <- liftIO $ run (findOwnerById id)
case owner of
Nothing -> status noContent204
Just o -> do
@ -1170,15 +1173,15 @@ routes pipe config = do
])
--Upsert owner to DB
post "/api/owner" $ do
s <- param "session"
u <- liftAndCatchIO $ run (findUser s)
s <- queryParam "session"
u <- liftIO $ run (findUser s)
o <- jsonData
now <- liftIO getCurrentTime
let q = payload (o :: Payload OwnerData)
case parseUserBson =<< u of
Nothing -> status internalServerError500
Just u' -> do
liftAndCatchIO $
liftIO $
run $
upsertOwner $
Owner
@ -1210,8 +1213,8 @@ routes pipe config = do
False
status accepted202
post "/api/ownersettings" $ do
s <- param "session"
u <- liftAndCatchIO $ run (findUser s)
s <- queryParam "session"
u <- liftIO $ run (findUser s)
o <- jsonData
now <- liftIO getCurrentTime
let q = payload (o :: Payload OwnerSettings)
@ -1220,12 +1223,12 @@ routes pipe config = do
Just u' -> do
if os_address q == uaddress u'
then do
liftAndCatchIO $ run $ updateOwnerSettings q
liftIO $ run $ updateOwnerSettings q
status accepted202
else status noContent204
post "/api/ownervk" $ do
s <- param "session"
u <- liftAndCatchIO $ run (findUser s)
s <- queryParam "session"
u <- liftIO $ run (findUser s)
o <- jsonData
let q = payload (o :: Payload String)
let qRaw = decodeBech32 $ C.pack q
@ -1242,12 +1245,12 @@ routes pipe config = do
qBytes
(bytes . decodeBech32 . C.pack . T.unpack $ uaddress u')
then do
owner <- liftAndCatchIO $ run (findOwner $ uaddress u')
owner <- liftIO $ run (findOwner $ uaddress u')
case cast' . Doc =<< owner of
Nothing -> status badRequest400
Just o' -> do
unless (oviewkey o' /= "") $ do
liftAndCatchIO $ run (upsertViewingKey o' q)
liftIO $ run (upsertViewingKey o' q)
status created201
else status forbidden403
else case decodeUfvk (C.pack q) of
@ -1260,14 +1263,12 @@ routes pipe config = do
(C.pack q)
(C.pack . T.unpack $ uaddress u')
then do
owner <-
liftAndCatchIO $ run (findOwner $ uaddress u')
owner <- liftIO $ run (findOwner $ uaddress u')
case cast' . Doc =<< owner of
Nothing -> status badRequest400
Just o' -> do
unless (oviewkey o' /= "") $ do
liftAndCatchIO $
run (upsertViewingKey o' q)
liftIO $ run (upsertViewingKey o' q)
status created201
else status forbidden403
Nothing -> do
@ -1276,27 +1277,24 @@ routes pipe config = do
(bytes . decodeBech32 . C.pack . T.unpack $
uaddress u')
then do
owner <-
liftAndCatchIO $ run (findOwner $ uaddress u')
owner <- liftIO $ run (findOwner $ uaddress u')
case cast' . Doc =<< owner of
Nothing -> status badRequest400
Just o' -> do
unless (oviewkey o' /= "") $ do
liftAndCatchIO $
run (upsertViewingKey o' q)
liftIO $ run (upsertViewingKey o' q)
status created201
else status forbidden403
--Get items associated with the given address
get "/api/items" $ do
session <- param "session"
user <- liftAndCatchIO $ run (findUser session)
session <- queryParam "session"
user <- liftIO $ 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
items <- liftIO $ run (findItems $ uaddress u)
if not (null items)
then do
let pItems = map (cast' . Doc) items :: [Maybe Item]
status ok200
Web.Scotty.json
@ -1304,41 +1302,42 @@ routes pipe config = do
[ "message" .= ("Items found!" :: String)
, "items" .= toJSON pItems
])
else status noContent204
--Upsert item
post "/api/item" $ do
i <- jsonData
session <- param "session"
user <- liftAndCatchIO $ run (findUser session)
session <- queryParam "session"
user <- liftIO $ 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)
_ <- liftIO $ run (upsertItem q)
status created201
else status forbidden403
--Delete item
Web.Scotty.delete "/api/item/:id" $ do
session <- param "session"
oId <- param "id"
u' <- liftAndCatchIO $ checkUser run session
session <- queryParam "session"
oId <- captureParam "id"
u' <- liftIO $ checkUser run session
case u' of
Nothing -> status forbidden403
Just u -> do
i <- liftAndCatchIO $ run (findItemById oId)
i <- liftIO $ 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)
liftIO $ run (deleteItem oId)
status ok200
else status forbidden403
--Get price for Zcash
get "/price" $ do
curr <- param "currency"
pr <- liftAndCatchIO $ run (findPrice curr)
curr <- queryParam "currency"
pr <- liftIO $ run (findPrice curr)
case parseZGoPrice =<< pr of
Nothing -> do
status noContent204
@ -1347,15 +1346,15 @@ routes pipe config = do
(object ["message" .= ("Price found!" :: String), "price" .= toJSON p])
--Get all closed orders for the address
get "/api/allorders" $ do
session <- param "session"
user <- liftAndCatchIO $ run (findUser session)
session <- queryParam "session"
user <- liftIO $ 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
myOrders <- liftIO $ run (findAllOrders $ uaddress u)
if null myOrders
then status noContent204
else do
let pOrders = map (cast' . Doc) myOrders :: [Maybe ZGoOrder]
status ok200
Web.Scotty.json
@ -1365,18 +1364,18 @@ routes pipe config = do
])
--Get order by id for receipts
get "/order/:id" $ do
oId <- param "id"
token <- param "token"
oId <- captureParam "id"
token <- queryParam "token"
let r = mkRegex "^[a-f0-9]{24}$"
if matchTest r oId
then do
myOrder <- liftAndCatchIO $ run (findOrderById oId)
myOrder <- liftIO $ run (findOrderById oId)
case cast' . Doc =<< myOrder of
Nothing -> status noContent204
Just pOrder -> do
if qtoken pOrder == token
then do
shop <- liftAndCatchIO $ run (findOwner $ qaddress pOrder)
shop <- liftIO $ run (findOwner $ qaddress pOrder)
case cast' . Doc =<< shop of
Nothing -> status badRequest400
Just s -> do
@ -1391,8 +1390,8 @@ routes pipe config = do
else status badRequest400
--Get order by session
get "/api/order" $ do
sess <- param "session"
myOrder <- liftAndCatchIO $ run (findOrder sess)
sess <- queryParam "session"
myOrder <- liftIO $ run (findOrder sess)
case myOrder of
Nothing -> status noContent204
Just o -> do
@ -1412,7 +1411,7 @@ routes pipe config = do
{-let q = payload (newOrder :: Payload ZGoOrder)-}
{-_ <- liftIO $ run (upsertXeroOrder q)-}
{-myOrder <--}
{-liftAndCatchIO $-}
{-liftIO $-}
{-run (findXeroOrder (qaddress q) (qexternalInvoice q) (qshortCode q))-}
{-case myOrder of-}
{-Nothing -> status noContent204-}
@ -1431,12 +1430,12 @@ routes pipe config = do
post "/api/order" $ do
newOrder <- jsonData
let q = payload (newOrder :: Payload ZGoOrder)
session <- param "session"
user <- liftAndCatchIO $ run (findUser session)
session <- queryParam "session"
user <- liftIO $ run (findUser session)
case cast' . Doc =<< user of
Nothing -> status unauthorized401
Just u -> do
owner <- liftAndCatchIO $ run $ findOwner (uaddress u)
owner <- liftIO $ run $ findOwner (uaddress u)
case cast' . Doc =<< owner of
Nothing -> status badRequest400
Just o -> do
@ -1448,8 +1447,7 @@ routes pipe config = do
if ovat o
then ovatValue o
else 0
dbOrder <-
liftAndCatchIO $ run (findOrderById $ maybe "0" show (q_id q))
dbOrder <- liftIO $ run (findOrderById $ maybe "0" show (q_id q))
case cast' . Doc =<< dbOrder of
Nothing -> do
if uaddress u == qaddress q
@ -1458,7 +1456,7 @@ routes pipe config = do
then do
t <- liftIO generateToken
_ <-
liftAndCatchIO $
liftIO $
run
(upsertOrder
(setOrderToken (T.pack t) q)
@ -1467,7 +1465,7 @@ routes pipe config = do
status created201
else do
_ <-
liftAndCatchIO $
liftIO $
access
pipe
master
@ -1484,7 +1482,7 @@ routes pipe config = do
then do
t <- liftIO generateToken
_ <-
liftAndCatchIO $
liftIO $
run
(upsertOrder
(setOrderToken (T.pack t) q)
@ -1493,7 +1491,7 @@ routes pipe config = do
status created201
else do
_ <-
liftAndCatchIO $
liftIO $
access
pipe
master
@ -1504,62 +1502,62 @@ routes pipe config = do
else status forbidden403
--Delete order
Web.Scotty.delete "/api/order/:id" $ do
oId <- param "id"
session <- param "session"
o <- liftAndCatchIO $ run (findOrderById oId)
oId <- captureParam "id"
session <- queryParam "session"
o <- liftIO $ run (findOrderById oId)
case cast' . Doc =<< o of
Nothing -> status badRequest400
Just order -> do
if qsession order == session
then do
liftAndCatchIO $ run (deleteOrder oId)
liftIO $ run (deleteOrder oId)
status ok200
else status forbidden403
-- Get language for component
get "/getmainlang" $ do
lang <- param "lang"
txtPack' <- liftAndCatchIO $ run (findLangComponent lang "main")
lang <- queryParam "lang"
txtPack' <- liftIO $ run (findLangComponent lang "main")
case cast' . Doc =<< txtPack' of
Nothing -> status noContent204
Just textPack -> do
status ok200
Web.Scotty.json $ toJSON (textPack :: LangComponent)
get "/getscanlang" $ do
lang <- param "lang"
txtPack' <- liftAndCatchIO $ run (findLangComponent lang "scan")
lang <- queryParam "lang"
txtPack' <- liftIO $ run (findLangComponent lang "scan")
case cast' . Doc =<< txtPack' of
Nothing -> status noContent204
Just textPack -> do
status ok200
Web.Scotty.json $ toJSON (textPack :: LangComponent)
get "/getloginlang" $ do
lang <- param "lang"
txtPack' <- liftAndCatchIO $ run (findLangComponent lang "login")
lang <- queryParam "lang"
txtPack' <- liftIO $ run (findLangComponent lang "login")
case cast' . Doc =<< txtPack' of
Nothing -> status noContent204
Just textPack -> do
status ok200
Web.Scotty.json $ toJSON (textPack :: LangComponent)
get "/getinvoicelang" $ do
lang <- param "lang"
txtPack' <- liftAndCatchIO $ run (findLangComponent lang "invoice")
lang <- queryParam "lang"
txtPack' <- liftIO $ 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")
lang <- queryParam "lang"
txtPack' <- liftIO $ 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"
txtPack' <- liftAndCatchIO $ run (findLangComponent lang component)
component <- queryParam "component"
lang <- queryParam "lang"
txtPack' <- liftIO $ run (findLangComponent lang component)
let txtPack = cast' . Doc =<< txtPack'
case txtPack of
Nothing -> status noContent204
@ -1569,7 +1567,7 @@ routes pipe config = do
{-post "/api/setlang" $ do-}
{-langComp <- jsonData-}
{-_ <--}
{-liftAndCatchIO $-}
{-liftIO $-}
{-mapM (run . loadLangComponent) (langComp :: [LangComponent])-}
{-status created201-}
{-(MonadIO m, FromJSON a)-}
@ -2007,17 +2005,17 @@ scanTxNative config pipe = do
filterTx t =
not (null (maybe [] rt_shieldedOutputs t)) ||
not (null (maybe [] rt_orchardActions t))
extractTxs :: Maybe BlockResponse -> [T.Text]
extractTxs :: Maybe BlockResponse -> [HexString]
extractTxs = maybe [] bl_txs
getTxData ::
BS.ByteString -> BS.ByteString -> T.Text -> IO (Maybe RawTxResponse)
BS.ByteString -> BS.ByteString -> HexString -> IO (Maybe RawTxResponse)
getTxData nodeUser nodePwd txid = do
txInfo <-
makeZcashCall
nodeUser
nodePwd
"getrawtransaction"
[Data.Aeson.String txid, Number $ SC.scientific 1 0]
[Data.Aeson.String (toText txid), Number $ SC.scientific 1 0]
let content = getResponseBody txInfo :: RpcResponse RawTxResponse
if isNothing (err content)
then return $ result content
@ -2075,7 +2073,7 @@ scanTxNative config pipe = do
(E.decodeUtf8Lenient $ a_memo n)
recordPayment :: Pipe -> T.Text -> T.Text -> ZcashTx -> IO ()
recordPayment p dbName z x = do
let zM = runParser pZGoMemo (T.unpack . ztxid $ x) (zmemo x)
let zM = runParser pZGoMemo (T.unpack . toText . ztxid $ x) (zmemo x)
case zM of
Right m -> do
case m_orderId m of
@ -2165,14 +2163,14 @@ instance Val BlockResponse where
h <- B.lookup "height" d
t <- B.lookup "time" d
txs <- B.lookup "tx" d
Just (BlockResponse c h t txs)
Just (BlockResponse c h t (map fromText txs))
cast' _ = Nothing
val (BlockResponse c h t txs) =
Doc
[ "confirmations" =: c
, "height" =: h
, "time" =: t
, "tx" =: txs
, "tx" =: (map toText txs)
, "network" =: ("mainnet" :: String)
]

View file

@ -1,86 +0,0 @@
# This file was automatically generated by 'stack init'
#
# Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see:
# https://docs.haskellstack.org/en/stable/yaml_configuration/
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
# A snapshot resolver dictates the compiler version and the set of packages
# to be used for project dependencies. For example:
#
# resolver: lts-3.5
# resolver: nightly-2015-09-21
# resolver: ghc-7.10.2
#
# The location of a snapshot can be provided as a file or url. Stack assumes
# a snapshot provided as a file might change, whereas a url resource does not.
#
# resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml
resolver: lts-21.22
#url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/4.yaml
# User packages to be built.
# Various formats can be used as shown in the example below.
#
# packages:
# - some-directory
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
# subdirs:
# - auto-update
# - wai
packages:
- .
# Dependency packages to be pulled from upstream that are not in the resolver.
# These entries can reference officially published versions as well as
# forks / in-progress versions pinned to a git hash. For example:
#
# extra-deps:
# - acme-missiles-0.3
# - git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
#
# extra-deps: []
extra-deps:
#- git: https://github.com/reach-sh/haskell-hexstring.git
#commit: 085c16fb21b9f856a435a3faab980e7e0b319341
- git: https://git.vergara.tech/Vergara_Tech/haskell-hexstring.git
commit: 085c16fb21b9f856a435a3faab980e7e0b319341
- git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git
commit: dce171d83043fae0e5c771ff743d31c4ec19c1ae
- git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git
commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05
- git: https://github.com/well-typed/borsh.git
commit: d2fcfa159e0a844b1ec5e8ed3e232d4b380fa831
- git: https://git.vergara.tech/Vergara_Tech/mongodb.git
commit: 63bba3a6d30e5fd73c71fd7da752b2647d94f58e
# - network-2.8.0.1@sha256:a79f3cf88b2623d5f2e7a8fc7962055f6858d6beb6d13c2aef43c20a5060cf28,3034
- 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
# flags: {}
# Extra package databases containing global packages
# extra-package-dbs: []
# Control whether we use the GHC we find on the path
# system-ghc: true
#
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: ">=2.7"
#
# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64
#
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]
#
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor

View file

@ -1,109 +0,0 @@
# This file was autogenerated by Stack.
# You should not edit this file by hand.
# For more information, please see the documentation at:
# https://docs.haskellstack.org/en/stable/lock_files
packages:
- completed:
commit: 085c16fb21b9f856a435a3faab980e7e0b319341
git: https://git.vergara.tech/Vergara_Tech/haskell-hexstring.git
name: hexstring
pantry-tree:
sha256: 9ecf67856f59dfb382b283eceb42e4fc1865935d1a7e59111556ed381c6a2ffd
size: 687
version: 0.11.1
original:
commit: 085c16fb21b9f856a435a3faab980e7e0b319341
git: https://git.vergara.tech/Vergara_Tech/haskell-hexstring.git
- completed:
commit: dce171d83043fae0e5c771ff743d31c4ec19c1ae
git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git
name: zcash-haskell
pantry-tree:
sha256: 000770930e5d50596b82b38984d6e8ab94fd5345c7fcf3cc21682ef8e6348746
size: 1365
version: 0.3.0
original:
commit: dce171d83043fae0e5c771ff743d31c4ec19c1ae
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:
commit: 63bba3a6d30e5fd73c71fd7da752b2647d94f58e
git: https://git.vergara.tech/Vergara_Tech/mongodb.git
name: mongoDB
pantry-tree:
sha256: 63af9dc2612131fb5d1ea9d75b7055d5d0b28ca443149be1fb47c22bf204128f
size: 2297
version: 2.7.1.2
original:
commit: 63bba3a6d30e5fd73c71fd7da752b2647d94f58e
git: https://git.vergara.tech/Vergara_Tech/mongodb.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:
sha256: 0264ef3e7919e7b0d668c4153f6ce0d88e6965626b52d9dfd2cafd70309501d3
size: 1433
original:
hackage: blake3-0.2@sha256:d1146b9a51ccfbb0532780778b6d016a614e3d44c05d8c1923dde9a8be869045,2448
- completed:
hackage: crypto-rng-0.3.0.1@sha256:04f4ae75943ecad8b794950985054130f272d65a588b6b6528f56df0bfedc4dc,1565
pantry-tree:
sha256: 1caccafe35d1ae3063f057c31188742a8e794f4f4e4530bab4019c0a514ee54f
size: 455
original:
hackage: crypto-rng-0.3.0.1@sha256:04f4ae75943ecad8b794950985054130f272d65a588b6b6528f56df0bfedc4dc,1565
snapshots:
- completed:
sha256: afd5ba64ab602cabc2d3942d3d7e7dd6311bc626dcb415b901eaf576cb62f0ea
size: 640060
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/22.yaml
original: lts-21.22

View file

@ -28,6 +28,7 @@ import Order
import Owner
import Payment
import System.IO.Unsafe
import Test.HUnit hiding (assert)
import Test.Hspec
import Test.Hspec.Expectations.Json
import Test.Hspec.QuickCheck
@ -36,7 +37,7 @@ import Test.QuickCheck.Gen
import Test.QuickCheck.Monadic
import Text.Megaparsec
import User
import Web.Scotty
import Web.Scotty hiding (getResponseStatus)
import WooCommerce
import Xero
import ZGoBackend
@ -169,7 +170,7 @@ main = do
res <- httpLBS req
getResponseStatus res `shouldBe` unauthorized401
describe "blockheight endpoint" $ do
it "returns a block number" $ do
xit "returns a block number" $ do
req <-
testGet
"/blockheight"
@ -776,10 +777,10 @@ main = do
describe "Database actions" $ do
describe "authentication" $ do
it "should succeed with good creds" $ \p -> do
r <- liftIO $ access p master "zgo" (auth "zgo" "zcashrules")
r <- liftIO $ access p master "test" (auth "zgo" "zcashrules")
r `shouldBe` True
it "should fail with bad creds" $ \p -> do
r <- liftIO $ access p master "zgo" (auth "user" "pwd")
r <- liftIO $ access p master "test" (auth "user" "pwd")
r `shouldBe` False
describe "ZGo Pro sessions" $ do
it "find in DB" $ \p -> do
@ -793,21 +794,21 @@ main = do
it "should update" $ \p -> do
doc <- access p master "test" $ findPrice "usd"
case doc of
Nothing -> True `shouldBe` False
Nothing -> assertFailure "couldn't find price"
Just d -> do
let q = parseZGoPrice d
case q of
Nothing -> True `shouldBe` False
Nothing -> assertFailure "couldn't parse price"
Just r -> do
let t1 = ZGoBackend.timestamp r
_ <- checkZcashPrices p "test"
doc2 <- access p master "test" $ findPrice "usd"
case doc2 of
Nothing -> True `shouldBe` False
Nothing -> assertFailure "couldn't find price"
Just d2 -> do
let q2 = parseZGoPrice d2
case q2 of
Nothing -> True `shouldBe` False
Nothing -> assertFailure "couldn't parse price"
Just r2 -> do
let t2 = ZGoBackend.timestamp r2
t2 `shouldSatisfy` (t1 <)
@ -1133,7 +1134,7 @@ testItemAdd i = do
openDbConnection :: IO Pipe
openDbConnection = do
pipe <- connect $ host "127.0.0.1"
access pipe master "zgo" (auth "zgo" "zcashrules")
access pipe master "test" (auth "zgo" "zcashrules")
return pipe
-- | Close the MongoDB pipe
@ -1156,7 +1157,7 @@ startAPI :: Config -> IO ()
startAPI config = do
putStrLn "Starting test server ..."
pipe <- connect $ host $ c_dbHost config
c <- access pipe master "zgo" (auth (c_dbUser config) (c_dbPassword config))
c <- access pipe master "test" (auth (c_dbUser config) (c_dbPassword config))
let appRoutes = routes pipe config
_ <- forkIO (scotty 3000 appRoutes)
_ <-

1
zcash-haskell Submodule

@ -0,0 +1 @@
Subproject commit 90c8a7c3028bd6836dea5655221277a25d457653

View file

@ -1,11 +1,11 @@
cabal-version: 1.12
cabal-version: 3.0
-- This file has been generated from package.yaml by hpack version 0.36.0.
--
-- see: https://github.com/sol/hpack
name: zgo-backend
version: 1.8.1
version: 1.9.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
@ -20,10 +20,6 @@ extra-source-files:
CHANGELOG.md
zgo.cfg
source-repository head
type: git
location: https://git.vergara.tech/Vergara_Tech/zgo-backend
library
exposed-modules:
Config
@ -37,8 +33,6 @@ library
Xero
ZGoBackend
ZGoTx
other-modules:
Paths_zgo_backend
hs-source-dirs:
src
build-depends:
@ -83,13 +77,11 @@ library
executable zgo-backend-exe
main-is: Server.hs
other-modules:
Tasks
TokenRefresh
Paths_zgo_backend
hs-source-dirs:
app
ghc-options: -main-is Server -threaded -rtsopts -with-rtsopts=-N -Wall
pkgconfig-depends:
rustzcash_wrapper
build-depends:
aeson
, base
@ -98,7 +90,7 @@ executable zgo-backend-exe
, http-conduit
, http-types
, megaparsec
, mongoDB
, mongoDB >=2.7.1.4
, scotty
, securemem
, text
@ -111,13 +103,11 @@ executable zgo-backend-exe
executable zgo-tasks
main-is: Tasks.hs
other-modules:
Server
TokenRefresh
Paths_zgo_backend
hs-source-dirs:
app
ghc-options: -main-is Tasks -threaded -rtsopts -with-rtsopts=-N -Wall
pkgconfig-depends:
rustzcash_wrapper
build-depends:
base
, megaparsec
@ -131,13 +121,11 @@ executable zgo-tasks
executable zgo-token-refresh
main-is: TokenRefresh.hs
other-modules:
Server
Tasks
Paths_zgo_backend
hs-source-dirs:
app
ghc-options: -main-is TokenRefresh -threaded -rtsopts -with-rtsopts=-N -Wall
pkgconfig-depends:
rustzcash_wrapper
build-depends:
aeson
, base
@ -160,11 +148,11 @@ executable zgo-token-refresh
test-suite zgo-backend-test
type: exitcode-stdio-1.0
main-is: Spec.hs
other-modules:
Paths_zgo_backend
hs-source-dirs:
test
ghc-options: -threaded -rtsopts -with-rtsopts=-N -main-is Spec
pkgconfig-depends:
rustzcash_wrapper
build-depends:
QuickCheck
, aeson
@ -175,6 +163,7 @@ test-suite zgo-backend-test
, hspec-expectations-json
, hspec-wai
, http-conduit
, HUnit
, http-types
, megaparsec
, mongoDB