Updated version of borsh
#10
2 changed files with 197 additions and 213 deletions
|
@ -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 <- formParam "code"
|
||||||
session <- param "session"
|
session <- formParam "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 <- formParam "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 <- formParam "session"
|
||||||
c <- param "code"
|
c <- formParam "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 <- formParam "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 <- formParam "ownerid"
|
||||||
session <- param "session"
|
session <- formParam "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 <- formParam "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 <- formParam "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,13 +1083,14 @@ routes pipe config = do
|
||||||
])
|
])
|
||||||
--Validate user, updating record
|
--Validate user, updating record
|
||||||
post "/validateuser" $ do
|
post "/validateuser" $ do
|
||||||
providedPin <- param "pin"
|
providedPin <- formParam "pin"
|
||||||
sess <- param "session"
|
sess <- formParam "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
|
||||||
|
@ -1102,30 +1104,29 @@ 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: " ++ 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 <- captureParam "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 +1138,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 <- formParam "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 +1154,8 @@ routes pipe config = do
|
||||||
, "owner" .= getOwnerSettings o
|
, "owner" .= getOwnerSettings o
|
||||||
])
|
])
|
||||||
get "/ownerid" $ do
|
get "/ownerid" $ do
|
||||||
id <- param "id"
|
id <- formParam "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 +1171,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 <- formParam "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 +1211,8 @@ routes pipe config = do
|
||||||
False
|
False
|
||||||
status accepted202
|
status accepted202
|
||||||
post "/api/ownersettings" $ do
|
post "/api/ownersettings" $ do
|
||||||
s <- param "session"
|
s <- formParam "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 +1221,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 <- formParam "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 +1243,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 +1261,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 +1275,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 <- formParam "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 +1300,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 <- formParam "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 <- formParam "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 <- formParam "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 +1344,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 <- formParam "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 +1362,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 <- formParam "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 +1388,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 <- formParam "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 +1409,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 +1428,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 <- formParam "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 +1445,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 +1454,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 +1463,7 @@ routes pipe config = do
|
||||||
status created201
|
status created201
|
||||||
else do
|
else do
|
||||||
_ <-
|
_ <-
|
||||||
liftAndCatchIO $
|
liftIO $
|
||||||
access
|
access
|
||||||
pipe
|
pipe
|
||||||
master
|
master
|
||||||
|
@ -1484,7 +1480,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 +1489,7 @@ routes pipe config = do
|
||||||
status created201
|
status created201
|
||||||
else do
|
else do
|
||||||
_ <-
|
_ <-
|
||||||
liftAndCatchIO $
|
liftIO $
|
||||||
access
|
access
|
||||||
pipe
|
pipe
|
||||||
master
|
master
|
||||||
|
@ -1504,62 +1500,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 <- formParam "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 +1565,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 +2003,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 +2071,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 +2161,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)
|
||||||
]
|
]
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue