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

Merge pull request 'Updated version of borsh' (#10) from dev19 into master

Browse source 
Reviewed-on: #10
This commit is contained in:
pitmutt 2024-05-21 17:28:42 +00:00 committed by Vergara Technologies LLC
commit a6d2426610
Signed by: Vergara Technologies LLC
GPG key ID: 99DB473BB4715618
10 changed files with 237 additions and 589 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
.gitignore vendored
View file

@ -1,2 +1,3 @@
.stack-work/ .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

167
package.yaml
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

384
src/ZGoBackend.hs
View file

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

86
stack.yaml
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

109
stack.yaml.lock
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

21
test/Spec.hs
View file

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

1
zcash-haskell Submodule

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

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