diff --git a/CHANGELOG.md b/CHANGELOG.md index 03b9130..28ec2bc 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,7 +4,39 @@ All notable changes to this project will be documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). -## [1.5.0] +## [1.7.0] + +### Added + +- Parameter to config for number of confirmations for scan +- Endpoint for language for invoices + +### Changed + +- Modified payment confirmation to use new WooCommerce plugin API endpoint. +- Consolidated the `invdata`, `orderid` and `orderx` endpoints +- The `xerotoken` endpoint uses `session` for authentication +- The order by ID/token endpoint includes shop name + +### Fixed + +- The viewing key obfuscation of blank viewing keys + +## [1.6.0] + +### Added + +- New JSON serialization for WooTokens. +- New `/api/ownervk` endpoint to save viewing keys +- Use of `zcash-haskell` library to validate Sapling viewing keys + +### Changed + +- Modified the process of scanning for payments to only scan addresses that have an active ZGo session and have enabled payment confirmations +- Modified the process to mark paid orders to ensure only payments to the shop's wallet get marked as paid +- Modified the `items` endpoint to use the login session to identify records + +## [1.5.0] - 2023-05-15 ### Added diff --git a/README.md b/README.md index e57f8f3..bdb9759 100644 --- a/README.md +++ b/README.md @@ -6,7 +6,8 @@ The API server behind the [ZGo.cash](https://zgo.cash) app. ## Dependencies -- Zcash Full node +- Zcash Full node (`zcashd`) +- [Zcash Haskell](https://git.vergara.tech/Vergara_Tech/zcash-haskell) - MongoDB ## Configuration diff --git a/package.yaml b/package.yaml index ca1e131..6953890 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: zgo-backend -version: 1.5.0 +version: 1.7.0 git: "https://git.vergara.tech/Vergara_Tech/zgo-backend" license: BOSL author: "Rene Vergara" @@ -62,6 +62,7 @@ library: - crypto-rng - megaparsec - uuid + - zcash-haskell executables: zgo-backend-exe: @@ -161,3 +162,6 @@ tests: - time - configurator - scotty + - megaparsec + - uuid + - zcash-haskell diff --git a/src/Config.hs b/src/Config.hs index 9455cca..0804305 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -26,6 +26,7 @@ data Config = , c_smtpPort :: Integer , c_smtpUser :: String , c_smtpPwd :: String + , c_confirmations :: Integer } deriving (Eq, Show) @@ -48,6 +49,7 @@ loadZGoConfig path = do mailPort <- require config "smtpPort" mailUser <- require config "smtpUser" mailPwd <- require config "smtpPwd" + conf <- require config "confirmations" return $ Config dbHost @@ -66,3 +68,4 @@ loadZGoConfig path = do mailPort mailUser mailPwd + conf diff --git a/src/Item.hs b/src/Item.hs index 6fef76e..b6ac41c 100644 --- a/src/Item.hs +++ b/src/Item.hs @@ -12,6 +12,7 @@ import Data.Time.Clock import Database.MongoDB import GHC.Generics import Test.QuickCheck +import User -- | Type to represent a ZGo item data Item = @@ -87,6 +88,9 @@ findItems :: T.Text -> Action IO [Document] findItems a = rest =<< find (select ["owner" =: a] "items") {sort = ["name" =: (1 :: Int)]} +findItemById :: String -> Action IO (Maybe Document) +findItemById i = findOne (select ["_id" =: (read i :: ObjectId)] "items") + upsertItem :: Item -> Action IO () upsertItem i = do let item = val i diff --git a/src/Order.hs b/src/Order.hs index b62d6ef..1aeefdb 100644 --- a/src/Order.hs +++ b/src/Order.hs @@ -29,11 +29,12 @@ data ZGoOrder = , qpaid :: Bool , qexternalInvoice :: T.Text , qshortCode :: T.Text + , qtoken :: T.Text } deriving (Eq, Show, Generic) instance ToJSON ZGoOrder where - toJSON (ZGoOrder i a s ts c cur p t tZ l paid eI sC) = + toJSON (ZGoOrder i a s ts c cur p t tZ l paid eI sC tk) = case i of Just oid -> object @@ -50,6 +51,7 @@ instance ToJSON ZGoOrder where , "paid" .= paid , "externalInvoice" .= eI , "shortCode" .= sC + , "token" .= tk ] Nothing -> object @@ -66,6 +68,7 @@ instance ToJSON ZGoOrder where , "paid" .= paid , "externalInvoice" .= eI , "shortCode" .= sC + , "token" .= tk ] instance FromJSON ZGoOrder where @@ -84,6 +87,7 @@ instance FromJSON ZGoOrder where pd <- obj .: "paid" eI <- obj .: "externalInvoice" sC <- obj .: "shortCode" + tk <- obj .: "token" pure $ ZGoOrder (if not (null i) @@ -101,9 +105,10 @@ instance FromJSON ZGoOrder where pd eI sC + tk instance Val ZGoOrder where - val (ZGoOrder i a s ts c cur p t tZ l pd eI sC) = + val (ZGoOrder i a s ts c cur p t tZ l pd eI sC tk) = if isJust i then Doc [ "_id" =: i @@ -119,6 +124,7 @@ instance Val ZGoOrder where , "paid" =: pd , "externalInvoice" =: eI , "shortCode" =: sC + , "token" =: tk ] else Doc [ "address" =: a @@ -133,6 +139,7 @@ instance Val ZGoOrder where , "paid" =: pd , "externalInvoice" =: eI , "shortCode" =: sC + , "token" =: tk ] cast' (Doc d) = do i <- B.lookup "_id" d @@ -148,7 +155,8 @@ instance Val ZGoOrder where pd <- B.lookup "paid" d eI <- B.lookup "externalInvoice" d sC <- B.lookup "shortCode" d - Just (ZGoOrder i a s ts c cur p t tZ l pd eI sC) + tk <- B.lookup "token" d + Just (ZGoOrder i a s ts c cur p t tZ l pd eI sC tk) cast' _ = Nothing -- Type to represent an order line item @@ -224,12 +232,17 @@ updateOrderTotals o = (qpaid o) (qexternalInvoice o) (qshortCode o) + (qtoken o) where newTotal :: ZGoOrder -> Double newTotal x = foldr tallyItems 0 (qlines x) tallyItems :: LineItem -> Double -> Double tallyItems y z = (lqty y * lcost y) + z +setOrderToken :: T.Text -> ZGoOrder -> ZGoOrder +setOrderToken token (ZGoOrder i a s ts c cur p t tZ l pd eI sC tk) = + ZGoOrder i a s ts c cur p t tZ l pd eI sC token + findOrder :: T.Text -> Action IO (Maybe Document) findOrder s = findOne (select ["session" =: s, "closed" =: False] "orders") diff --git a/src/Owner.hs b/src/Owner.hs index 867f923..e1dbfa2 100644 --- a/src/Owner.hs +++ b/src/Owner.hs @@ -366,8 +366,12 @@ instance ToJSON OwnerSettings where , "expiration" .= e , "payconf" .= pc , "crmToken" .= cT - , "viewkey" .= (T.take 8 vK <> "...." <> T.takeEnd 8 vK) + , "viewkey" .= keyObfuscate vK ] + where + keyObfuscate s + | s == "" = "" + | otherwise = T.take 8 s <> "...." <> T.takeEnd 8 s -- Helper Functions getOwnerSettings :: Owner -> OwnerSettings @@ -407,6 +411,10 @@ findOwnerById :: T.Text -> Action IO (Maybe Document) findOwnerById i = findOne (select ["_id" =: (read (T.unpack i) :: ObjectId)] "owners") +findActiveOwners :: Action IO [Document] +findActiveOwners = + rest =<< find (select ["paid" =: True, "payconf" =: True] "owners") + -- | Function to find Owners about to expire findExpiringOwners :: UTCTime -> Action IO [Document] findExpiringOwners now = @@ -437,6 +445,10 @@ updateOwnerSettings os = ] ] +upsertViewingKey :: Owner -> String -> Action IO () +upsertViewingKey o vk = + modify (select ["_id" =: o_id o] "owners") ["$set" =: ["viewKey" =: vk]] + -- | Type for a pro session data ZGoProSession = ZGoProSession diff --git a/src/User.hs b/src/User.hs index a393dc5..e7eb241 100644 --- a/src/User.hs +++ b/src/User.hs @@ -69,6 +69,36 @@ instance FromJSON User where "" v +instance Val User where + cast' (Doc d) = do + i <- B.lookup "_id" d + a <- B.lookup "address" d + s <- B.lookup "session" d + b <- B.lookup "blocktime" d + p <- B.lookup "pin" d + v <- B.lookup "validated" d + Just $ User i a s b p v + cast' _ = Nothing + val (User i a s b p v) = + case i of + Just oid -> + Doc + [ "_id" =: oid + , "address" =: a + , "session" =: s + , "blocktime" =: b + , "pin" =: p + , "validated" =: v + ] + Nothing -> + Doc + [ "address" =: a + , "session" =: s + , "blocktime" =: b + , "pin" =: p + , "validated" =: v + ] + parseUserBson :: B.Document -> Maybe User parseUserBson d = do i <- B.lookup "_id" d @@ -84,6 +114,9 @@ parseUserBson d = do findUser :: T.Text -> Action IO (Maybe Document) findUser s = findOne (select ["session" =: s] "users") +findUserById :: String -> Action IO (Maybe Document) +findUserById i = findOne (select ["_id" =: (read i :: B.ObjectId)] "users") + -- | Function to delete user by ID deleteUser :: String -> Action IO () deleteUser i = deleteOne (select ["_id" =: (read i :: B.ObjectId)] "users") diff --git a/src/WooCommerce.hs b/src/WooCommerce.hs index a7b16b4..5530e18 100644 --- a/src/WooCommerce.hs +++ b/src/WooCommerce.hs @@ -28,6 +28,29 @@ data WooToken = } deriving (Eq, Show) +instance FromJSON WooToken where + parseJSON = + withObject "WooToken" $ \obj -> do + i <- obj .:? "_id" + o <- obj .: "ownerid" + t <- obj .: "token" + u <- obj .: "siteurl" + pure $ WooToken (read <$> i) (read o) t u + +instance ToJSON WooToken where + toJSON (WooToken i o t u) = + case i of + Just oid -> + object + ["_id" .= show oid, "ownerid" .= show o, "token" .= t, "siteurl" .= u] + Nothing -> + object + [ "_id" .= ("" :: String) + , "ownerid" .= show o + , "token" .= t + , "siteurl" .= u + ] + instance Val WooToken where val (WooToken i o t u) = if isJust i @@ -47,8 +70,11 @@ instance Val WooToken where cast' _ = Nothing -- Database actions -findWooToken :: ObjectId -> Action IO (Maybe Document) -findWooToken oid = findOne (select ["owner" =: oid] "wootokens") +findWooToken :: Maybe ObjectId -> Action IO (Maybe Document) +findWooToken oid = + case oid of + Nothing -> return Nothing + Just o -> findOne (select ["owner" =: o] "wootokens") addUrl :: WooToken -> T.Text -> Action IO () addUrl t u = @@ -63,8 +89,9 @@ payWooOrder :: -> BS.ByteString -- Total ZEC for order -> IO () payWooOrder u i o t p z = do - wooReq <- parseRequest $ u ++ "/wc-api/zpmtcallback" + wooReq <- parseRequest u let req = + setRequestPath "/wp-json/wc/v3/zgocallback" $ setRequestQueryString [ ("token", Just t) , ("orderid", Just o) @@ -77,23 +104,15 @@ payWooOrder u i o t p z = do res <- httpLBS req if getResponseStatus res == ok200 then return () - else error "Failed to report payment to WooCommerce" + else do + print $ getResponseStatus res + error "Failed to report payment to WooCommerce" -generateWooToken :: Owner -> Action IO () -generateWooToken o = +generateWooToken :: Owner -> String -> Action IO () +generateWooToken o s = case o_id o of Just ownerid -> do - let tokenHash = - BLK.hash - [ BA.pack . BS.unpack . C.pack . T.unpack $ oname o <> oaddress o :: BA.Bytes - ] - let wooToken = - val $ - WooToken - Nothing - ownerid - (T.pack . show $ (tokenHash :: BLK.Digest BLK.DEFAULT_DIGEST_LEN)) - Nothing + let wooToken = val $ WooToken Nothing ownerid (T.pack s) Nothing case wooToken of Doc wT -> insert_ "wootokens" wT _ -> error "Couldn't create the WooCommerce token" diff --git a/src/Xero.hs b/src/Xero.hs index 009caf2..2540e10 100644 --- a/src/Xero.hs +++ b/src/Xero.hs @@ -171,6 +171,26 @@ instance FromJSON XeroTenant where --u <- obj .: "updatedDateUtc" pure $ XeroTenant i aei tI tT tN +data XeroInvoiceRequest = + XeroInvoiceRequest + { xr_owner :: T.Text + , xr_invNo :: T.Text + , xr_amount :: Double + , xr_currency :: T.Text + , xr_shortCode :: T.Text + } + deriving (Show, Eq) + +instance FromJSON XeroInvoiceRequest where + parseJSON = + withObject "XeroInvoiceRequest" $ \obj -> do + o <- obj .: "ownerId" + i <- obj .: "invoice" + a <- obj .: "amount" + c <- obj .: "currency" + s <- obj .: "shortcode" + pure $ XeroInvoiceRequest o i a c s + data XeroInvoice = XeroInvoice { xi_id :: Maybe ObjectId @@ -443,5 +463,6 @@ payXeroInvoice pipe dbName inv address amt zec = do setRequestHost "api.xero.com" $ setRequestMethod "PUT" defaultRequest res <- httpJSON req :: IO (Response Object) + print res return () else error "Invalid parameters" diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 0243fb6..99d5cde 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -12,6 +12,8 @@ import Control.Concurrent (forkIO, threadDelay) import Control.Exception (try) import Control.Monad import Control.Monad.IO.Class +import Crypto.RNG (newCryptoRNGState, runCryptoRNGT) +import Crypto.RNG.Utils (randomString) import Data.Aeson import Data.Array import qualified Data.Bson as B @@ -37,7 +39,7 @@ import qualified Data.UUID as U import qualified Data.Vector as V import Data.Vector.Internal.Check (doChecks) import Data.Word -import Database.MongoDB +import Database.MongoDB hiding (Order) import Debug.Trace import GHC.Generics import Item @@ -64,6 +66,9 @@ import Web.Scotty import WooCommerce import Xero import ZGoTx +import ZcashHaskell.Sapling +import ZcashHaskell.Types (RawData(..)) +import ZcashHaskell.Utils (decodeBech32) -- Models for API objects -- | A type to model Zcash RPC calls @@ -586,7 +591,7 @@ routes pipe config = do simpleCorsResourcePolicy { corsRequestHeaders = ["Authorization", "Content-Type"] , corsMethods = "DELETE" : simpleMethods - --, corsOrigins = Nothing + , corsOrigins = Nothing } middleware $ basicAuth @@ -623,102 +628,288 @@ routes pipe config = do ]) get "/api/xerotoken" $ do code <- param "code" - address <- param "address" + session <- param "session" + user <- liftAndCatchIO $ run (findUser session) xeroConfig <- liftAndCatchIO $ run findXero - case xeroConfig of + case cast' . Doc =<< xeroConfig of Nothing -> status noContent204 - Just x -> do - let xConfig = cast' (Doc x) - case xConfig of - Nothing -> status noContent204 - Just c -> do + Just c -> do + case cast' . Doc =<< user of + Nothing -> status unauthorized401 + Just u -> do res <- liftAndCatchIO $ - requestXeroToken pipe (c_dbName config) c code address + requestXeroToken pipe (c_dbName config) c code $ uaddress u if res then status ok200 else status noContent204 - get "/api/invdata" $ do - inv <- param "inv" - oAddress <- param "address" + post "/invdata" $ do + invData <- jsonData xeroConfig <- liftAndCatchIO $ run findXero - case xeroConfig of + let invReq = payload (invData :: Payload XeroInvoiceRequest) + case cast' . Doc =<< xeroConfig of Nothing -> do - status noContent204 - text "Xero App credentials not found" - Just x -> do - let xConfig = cast' (Doc x) - case xConfig of + status ok200 + Web.Scotty.json + (object + [ "reportType" .= (1 :: Integer) + , "order" .= (Nothing :: Maybe ZGoOrder) + , "shop" .= (Nothing :: Maybe String) + ]) + Just c -> do + o <- liftAndCatchIO $ run $ findOwnerById $ xr_owner invReq + case cast' . Doc =<< o of Nothing -> do - status noContent204 - text "Xero App credentials corrupted" - Just c -> do - res <- + status ok200 + Web.Scotty.json + (object + [ "reportType" .= (2 :: Integer) + , "order" .= (Nothing :: Maybe ZGoOrder) + , "shop" .= (Nothing :: Maybe String) + ]) + Just o' -> do + existingOrder <- liftAndCatchIO $ - requestXeroToken pipe (c_dbName config) c "none" oAddress - if res - then do - resInv <- + run $ + findXeroOrder + (oaddress o') + (xr_invNo invReq) + (xr_shortCode invReq) + case cast' . Doc =<< existingOrder of + Nothing -> do + res <- liftAndCatchIO $ - getXeroInvoice pipe (c_dbName config) inv oAddress - case resInv of - Nothing -> do - status noContent204 - text "Xero invoice not found" - Just xI -> do + requestXeroToken pipe (c_dbName config) c "none" $ oaddress o' + if res + then do + resInv <- + liftAndCatchIO $ + getXeroInvoice pipe (c_dbName config) (xr_invNo invReq) $ + oaddress o' + case resInv of + Nothing -> do + status ok200 + Web.Scotty.json + (object + [ "reportType" .= (2 :: Integer) + , "order" .= (Nothing :: Maybe ZGoOrder) + , "shop" .= (Nothing :: Maybe String) + ]) + Just xI -> do + if xi_type xI == "ACCREC" + then if xi_status xI == "AUTHORISED" + then if xi_currency xI == + T.toUpper (ocurrency o') + then if xi_total xI == xr_amount invReq + then do + now <- liftIO getCurrentTime + tk <- liftIO generateToken + pr <- + liftAndCatchIO $ + run + (findPrice $ + T.unpack . ocurrency $ o') + case parseZGoPrice =<< pr of + Nothing -> do + status ok200 + Web.Scotty.json + (object + [ "reportType" .= + (7 :: Integer) + , "order" .= + (Nothing :: Maybe ZGoOrder) + , "shop" .= + (Nothing :: Maybe String) + ]) + Just cp -> do + let newOrder = + ZGoOrder + Nothing + (oaddress o') + ("Xero-" <> + maybe + "" + (T.pack . show) + (o_id o')) + now + True + (ocurrency o') + (price cp) + (xi_total xI) + (xi_total xI / + price cp) + [ LineItem + 1 + ("Invoice from " <> + oname o' <> + " [" <> + xi_number xI <> + "]") + (xi_total xI) + ] + False + (xi_number xI) + (xr_shortCode + invReq) + (T.pack tk) + _ <- + liftAndCatchIO $ + run $ + upsertOrder newOrder + finalOrder <- + liftAndCatchIO $ + run $ + findXeroOrder + (oaddress o') + (xi_number xI) + (xr_shortCode invReq) + case cast' . Doc =<< + finalOrder of + Nothing -> do + status + internalServerError500 + text + "Unable to save order to DB" + Just fO -> do + status created201 + Web.Scotty.json + (object + [ "reportType" .= + (0 :: Integer) + , "order" .= + toJSON + (fO :: ZGoOrder) + , "shop" .= + oname o' + ]) + else do + status ok200 + Web.Scotty.json + (object + [ "reportType" .= + (8 :: Integer) + , "order" .= + (Nothing :: Maybe ZGoOrder) + , "shop" .= + (Nothing :: Maybe String) + ]) + else do + status ok200 + Web.Scotty.json + (object + [ "reportType" .= (7 :: Integer) + , "order" .= + (Nothing :: Maybe ZGoOrder) + , "shop" .= + (Nothing :: Maybe String) + ]) + else do + status ok200 + Web.Scotty.json + (object + [ "reportType" .= (6 :: Integer) + , "order" .= (Nothing :: Maybe ZGoOrder) + , "shop" .= (Nothing :: Maybe String) + ]) + else do + status ok200 + Web.Scotty.json + (object + [ "reportType" .= (5 :: Integer) + , "order" .= (Nothing :: Maybe ZGoOrder) + , "shop" .= (Nothing :: Maybe String) + ]) + else do status ok200 - Web.Scotty.json (object ["invdata" .= toJSON xI]) - else status noContent204 + Web.Scotty.json + (object + [ "reportType" .= (1 :: Integer) + , "order" .= (Nothing :: Maybe ZGoOrder) + , "shop" .= (Nothing :: Maybe String) + ]) + Just eO -> do + status created201 + Web.Scotty.json + (object + [ "reportType" .= (0 :: Integer) + , "order" .= toJSON (eO :: ZGoOrder) + , "shop" .= oname o' + ]) -- Get the xeroaccount code get "/api/xeroaccount" $ do - oAdd <- param "address" - res <- liftAndCatchIO $ run (findToken oAdd) - let c = cast' . Doc =<< res - case c of - Nothing -> status noContent204 - Just c1 -> do - status ok200 - Web.Scotty.json - (object - [ "message" .= ("Xero account code found" :: String) - , "code" .= t_code c1 - ]) + session <- param "session" + user <- liftAndCatchIO $ run (findUser session) + case cast' . Doc =<< user of + Nothing -> status unauthorized401 + Just u -> do + res <- liftAndCatchIO $ run (findToken $ uaddress u) + let c = cast' . Doc =<< res + case c of + Nothing -> status noContent204 + Just c1 -> do + status ok200 + Web.Scotty.json + (object + [ "message" .= ("Xero account code found" :: String) + , "code" .= t_code c1 + ]) -- Save the xeroaccount code post "/api/xeroaccount" $ do - oAdd <- param "address" + session <- param "session" c <- param "code" - liftAndCatchIO $ run (addAccCode oAdd c) - status accepted202 + user <- liftAndCatchIO $ run (findUser session) + case cast' . Doc =<< user of + Nothing -> status unauthorized401 + Just u -> do + let oAdd = uaddress u + liftAndCatchIO $ run (addAccCode oAdd c) + status accepted202 -- Get the WooCommerce token get "/api/wootoken" $ do - oid <- param "ownerid" - res <- liftAndCatchIO $ run (findWooToken (read oid)) - let t1 = cast' . Doc =<< res - case t1 of - Nothing -> status noContent204 - Just t -> do - status ok200 - Web.Scotty.json - (object - [ "ownerid" .= show (w_owner t) - , "token" .= w_token t - , "siteurl" .= w_url t - ]) + session <- param "session" + user <- liftAndCatchIO $ run (findUser session) + case cast' . Doc =<< user of + Nothing -> status unauthorized401 + Just u -> do + owner <- liftAndCatchIO $ run (findOwner $ uaddress u) + case cast' . Doc =<< owner of + Nothing -> status internalServerError500 + Just o -> do + res <- liftAndCatchIO $ run (findWooToken $ o_id o) + let t1 = cast' . Doc =<< res + case t1 of + Nothing -> status noContent204 + Just t -> do + status ok200 + Web.Scotty.json + (object + [ "ownerid" .= show (w_owner t) + , "token" .= w_token t + , "siteurl" .= w_url t + ]) post "/api/wootoken" $ do oid <- param "ownerid" - res <- liftAndCatchIO $ run (findOwnerById oid) - let o1 = cast' . Doc =<< res - case o1 of - Nothing -> status noContent204 - Just o -> do - liftAndCatchIO $ run (generateWooToken o) - status accepted202 + session <- param "session" + user <- liftAndCatchIO $ run (findUser session) + case cast' . Doc =<< user of + Nothing -> status unauthorized401 + Just u -> do + res <- liftAndCatchIO $ run (findOwnerById oid) + case cast' . Doc =<< res of + Nothing -> status badRequest400 + Just o -> do + if oaddress o == uaddress u + then do + tk <- liftIO generateToken + liftAndCatchIO $ run (generateWooToken o tk) + status accepted202 + else status forbidden403 -- Authenticate the WooCommerce plugin get "/auth" $ do oid <- param "ownerid" t <- param "token" siteurl <- param "siteurl" - res <- liftAndCatchIO $ run (findWooToken (read oid)) + res <- liftAndCatchIO $ run (findWooToken $ Just (read oid)) let c1 = cast' . Doc =<< res case c1 of Nothing -> do @@ -727,7 +918,7 @@ routes pipe config = do (object ["authorized" .= False, "message" .= ("Owner not found" :: String)]) Just c -> - if t == w_token c + if blk3Hash t == blk3Hash (T.unpack $ w_token c) then if isNothing (w_url c) then do liftAndCatchIO $ run (addUrl c siteurl) @@ -765,6 +956,10 @@ routes pipe config = do [ "authorized" .= False , "message" .= ("Token mismatch" :: String) ]) + where blk3Hash :: String -> String + blk3Hash s = + show + (BLK.hash [BA.pack . BS.unpack . C.pack $ s :: BA.Bytes] :: BLK.Digest BLK.DEFAULT_DIGEST_LEN) get "/woopayment" $ do oid <- param "ownerid" t <- param "token" @@ -774,7 +969,7 @@ routes pipe config = do amount <- param "amount" sUrl <- param "siteurl" orderKey <- param "orderkey" - res <- liftAndCatchIO $ run (findWooToken (read oid)) + res <- liftAndCatchIO $ run (findWooToken $ Just (read oid)) let c = cast' . Doc =<< res case c of Nothing -> do @@ -806,6 +1001,7 @@ routes pipe config = do Just o -> if opaid o then do + tk <- liftIO generateToken let newOrder = ZGoOrder Nothing @@ -832,9 +1028,11 @@ routes pipe config = do (T.concat [T.pack sUrl, "-", ordId, "-", orderKey]) "" + (T.pack tk) newId <- liftAndCatchIO $ run (insertWooOrder newOrder) status ok200 - Web.Scotty.json (object ["order" .= show newId]) + Web.Scotty.json + (object ["order" .= show newId, "token" .= tk]) else do status accepted202 Web.Scotty.json @@ -893,12 +1091,20 @@ routes pipe config = do --Delete user Web.Scotty.delete "/api/user/:id" $ do userId <- param "id" + session <- param "session" let r = mkRegex "^[a-f0-9]{24}$" if matchTest r userId then do - liftAndCatchIO $ run (deleteUser userId) - status ok200 - else status noContent204 + u <- liftAndCatchIO $ run (findUserById userId) + case cast' . Doc =<< u of + Nothing -> status badRequest400 + Just u' -> + if session == usession u' + then do + liftAndCatchIO $ run (deleteUser userId) + status ok200 + else status forbidden403 + else status badRequest400 --Get current blockheight from Zcash node get "/blockheight" $ do blockInfo <- @@ -929,7 +1135,7 @@ routes pipe config = do [ "message" .= ("Owner found!" :: String) , "owner" .= getOwnerSettings o ]) - get "/api/ownerid" $ do + get "/ownerid" $ do id <- param "id" owner <- liftAndCatchIO $ run (findOwnerById id) case owner of @@ -943,23 +1149,7 @@ routes pipe config = do Web.Scotty.json (object [ "message" .= ("Owner found!" :: String) - , "owner" .= - object - [ "_id" .= (maybe "" show $ o_id q :: String) - , "address" .= oaddress q - , "name" .= oname q - , "currency" .= ocurrency q - , "tax" .= otax q - , "taxValue" .= otaxValue q - , "vat" .= ovat q - , "vatValue" .= ovatValue q - , "paid" .= opaid q - , "zats" .= ozats q - , "invoices" .= oinvoices q - , "expiration" .= oexpiration q - , "payconf" .= opayconf q - , "crmToken" .= ocrmToken q - ] + , "owner" .= getOwnerSettings q ]) --Upsert owner to DB post "/api/owner" $ do @@ -1015,33 +1205,99 @@ routes pipe config = do liftAndCatchIO $ run $ updateOwnerSettings q status accepted202 else status noContent204 + post "/api/ownervk" $ do + s <- param "session" + u <- liftAndCatchIO $ run (findUser s) + o <- jsonData + let q = payload (o :: Payload String) + let qRaw = decodeBech32 $ C.pack q + if hrp qRaw == "fail" + then status badRequest400 + else do + let qBytes = bytes qRaw + case cast' . Doc =<< u of + Nothing -> status unauthorized401 + Just u' -> do + if isValidSaplingViewingKey qBytes + then if matchSaplingAddress + qBytes + (bytes . decodeBech32 . C.pack . T.unpack $ uaddress u') + then do + owner <- liftAndCatchIO $ run (findOwner $ uaddress u') + case cast' . Doc =<< owner of + Nothing -> status badRequest400 + Just o' -> do + unless (oviewkey o' /= "") $ do + vkInfo <- + liftAndCatchIO $ + makeZcashCall + nodeUser + nodePwd + "z_importviewingkey" + [ Data.Aeson.String (T.strip . T.pack $ q) + , "no" + ] + let content = + getResponseBody vkInfo :: RpcResponse Object + if isNothing (err content) + then do + _ <- + liftAndCatchIO $ run (upsertViewingKey o' q) + status created201 + else do + text $ L.pack . show $ err content + status badRequest400 + else status forbidden403 + else status badRequest400 --Get items associated with the given address get "/api/items" $ do - addr <- param "address" - items <- liftAndCatchIO $ run (findItems addr) - case items of - [] -> status noContent204 - _ -> do - let pItems = map (cast' . Doc) items :: [Maybe Item] - status ok200 - Web.Scotty.json - (object - ["message" .= ("Items found!" :: String), "items" .= toJSON pItems]) + session <- param "session" + user <- liftAndCatchIO $ run (findUser session) + case cast' . Doc =<< user of + Nothing -> status forbidden403 + Just u -> do + items <- liftAndCatchIO $ run (findItems $ uaddress u) + case items of + [] -> status noContent204 + _ -> do + let pItems = map (cast' . Doc) items :: [Maybe Item] + status ok200 + Web.Scotty.json + (object + [ "message" .= ("Items found!" :: String) + , "items" .= toJSON pItems + ]) --Upsert item post "/api/item" $ do i <- jsonData - let q = payload (i :: Payload Item) - _ <- liftAndCatchIO $ run (upsertItem q) - status created201 + session <- param "session" + user <- liftAndCatchIO $ run (findUser session) + case cast' . Doc =<< user of + Nothing -> status forbidden403 + Just u -> do + let q = payload (i :: Payload Item) + if uaddress u == iowner q + then do + _ <- liftAndCatchIO $ run (upsertItem q) + status created201 + else status forbidden403 --Delete item Web.Scotty.delete "/api/item/:id" $ do + session <- param "session" oId <- param "id" - let r = mkRegex "^[a-f0-9]{24}$" - if matchTest r oId - then do - liftAndCatchIO $ run (deleteItem oId) - status ok200 - else status noContent204 + u' <- liftAndCatchIO $ checkUser run session + case u' of + Nothing -> status forbidden403 + Just u -> do + i <- liftAndCatchIO $ run (findItemById oId) + case cast' . Doc =<< i of + Nothing -> status badRequest400 + Just i' -> do + if iowner i' == uaddress u + then do + liftAndCatchIO $ run (deleteItem oId) + status ok200 + else status forbidden403 --Get price for Zcash get "/price" $ do curr <- param "currency" @@ -1057,39 +1313,48 @@ routes pipe config = do ]) --Get all closed orders for the address get "/api/allorders" $ do - addr <- param "address" - myOrders <- liftAndCatchIO $ run (findAllOrders addr) - case myOrders of - [] -> status noContent204 - _ -> do - let pOrders = map (cast' . Doc) myOrders :: [Maybe ZGoOrder] - status ok200 - Web.Scotty.json - (object - [ "message" .= ("Orders found!" :: String) - , "orders" .= toJSON pOrders - ]) + session <- param "session" + user <- liftAndCatchIO $ run (findUser session) + case cast' . Doc =<< user of + Nothing -> status unauthorized401 + Just u -> do + myOrders <- liftAndCatchIO $ run (findAllOrders $ uaddress u) + case myOrders of + [] -> status noContent204 + _ -> do + let pOrders = map (cast' . Doc) myOrders :: [Maybe ZGoOrder] + status ok200 + Web.Scotty.json + (object + [ "message" .= ("Orders found!" :: String) + , "orders" .= toJSON pOrders + ]) --Get order by id for receipts - get "/api/order/:id" $ do + get "/order/:id" $ do oId <- param "id" + token <- param "token" let r = mkRegex "^[a-f0-9]{24}$" if matchTest r oId then do myOrder <- liftAndCatchIO $ run (findOrderById oId) - case myOrder of + case cast' . Doc =<< myOrder of Nothing -> status noContent204 - Just o -> do - let o' = cast' (Doc o) - case o' of - Nothing -> status internalServerError500 - Just pOrder -> do - status ok200 - Web.Scotty.json - (object - [ "message" .= ("Order found!" :: String) - , "order" .= toJSON (pOrder :: ZGoOrder) - ]) - else status noContent204 + Just pOrder -> do + if qtoken pOrder == token + then do + shop <- liftAndCatchIO $ run (findOwner $ qaddress pOrder) + case cast' . Doc =<< shop of + Nothing -> status badRequest400 + Just s -> do + status ok200 + Web.Scotty.json + (object + [ "message" .= ("Order found!" :: String) + , "order" .= toJSON (pOrder :: ZGoOrder) + , "shop" .= (oname s :: T.Text) + ]) + else status forbidden403 + else status badRequest400 --Get order by session get "/api/order" $ do sess <- param "session" @@ -1132,13 +1397,37 @@ routes pipe config = do post "/api/order" $ do newOrder <- jsonData let q = payload (newOrder :: Payload ZGoOrder) - _ <- liftAndCatchIO $ run (upsertOrder q) - status created201 + session <- param "session" + user <- liftAndCatchIO $ run (findUser session) + case cast' . Doc =<< user of + Nothing -> status unauthorized401 + Just u -> do + if uaddress u == qaddress q + then do + if qtoken q == "" + then do + t <- liftIO generateToken + _ <- + liftAndCatchIO $ + run (upsertOrder $ setOrderToken (T.pack t) q) + status created201 + else do + _ <- liftAndCatchIO $ run (upsertOrder q) + status created201 + else status forbidden403 --Delete order Web.Scotty.delete "/api/order/:id" $ do oId <- param "id" - liftAndCatchIO $ run (deleteOrder oId) - status ok200 + session <- param "session" + o <- liftAndCatchIO $ run (findOrderById oId) + case cast' . Doc =<< o of + Nothing -> status badRequest400 + Just order -> do + if qsession order == session + then do + liftAndCatchIO $ run (deleteOrder oId) + status ok200 + else status forbidden403 -- Get language for component get "/getmainlang" $ do lang <- param "lang" @@ -1164,6 +1453,22 @@ routes pipe config = do Just textPack -> do status ok200 Web.Scotty.json $ toJSON (textPack :: LangComponent) + get "/getinvoicelang" $ do + lang <- param "lang" + txtPack' <- liftAndCatchIO $ run (findLangComponent lang "invoice") + case cast' . Doc =<< txtPack' of + Nothing -> status noContent204 + Just textPack -> do + status ok200 + Web.Scotty.json $ toJSON (textPack :: LangComponent) + get "/getpmtservicelang" $ do + lang <- param "lang" + txtPack' <- liftAndCatchIO $ run (findLangComponent lang "pmtservice") + case cast' . Doc =<< txtPack' of + Nothing -> status noContent204 + Just textPack -> do + status ok200 + Web.Scotty.json $ toJSON (textPack :: LangComponent) get "/api/getlang" $ do component <- param "component" lang <- param "lang" @@ -1251,36 +1556,10 @@ listTxs user pwd a confs = do Just e -> return $ Left $ "Error reading transactions: " <> emessage e Left ex -> return $ Left $ (T.pack . show) ex --- | Function to check the ZGo full node for new txs -scanZcash :: Config -> Pipe -> IO () -scanZcash config pipe = do - myTxs <- - listTxs (c_nodeUser config) (c_nodePwd config) (c_nodeAddress config) 1 - case myTxs of - Right txs -> do - let r = - mkRegex - ".*ZGO::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12})\\sReply-To:\\s(zs[a-z0-9]{76}).*" - let p = - mkRegex - ".*ZGOp::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12}).*" - let y = - mkRegex - ".*MSG\\s(zs[a-z0-9]{76})\\s+ZGO::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12}).*" - let k = map zToZGoTx (filter (isRelevant r) txs) - mapM_ (access pipe master (c_dbName config) . upsertZGoTx "txs") k - let j = map zToZGoTx (filter (isRelevant p) txs) - mapM_ (upsertPayment pipe (c_dbName config)) j - let l = map zToZGoTx (filter (isRelevant y) txs) - mapM_ (access pipe master (c_dbName config) . upsertZGoTx "txs") l - Left e -> do - putStrLn $ "Error scanning node transactions: " ++ T.unpack e - return () - -- | Function to filter transactions -isRelevant :: Text.Regex.Regex -> ZcashTx -> Bool -isRelevant re t - | zconfirmations t < 100 && (matchTest re . T.unpack . zmemo) t = True +isRelevant :: Integer -> Text.Regex.Regex -> ZcashTx -> Bool +isRelevant conf re t + | zconfirmations t < conf && (matchTest re . T.unpack . zmemo) t = True | otherwise = False -- | New function to scan transactions with parser @@ -1296,85 +1575,103 @@ scanZcash' config pipe = do -- | Function to scan loaded viewing keys for payments scanPayments :: Config -> Pipe -> IO () scanPayments config pipe = do - shops <- listAddresses (c_nodeUser config) (c_nodePwd config) - mapM_ (findPaidOrders config pipe) shops - where - findPaidOrders :: Config -> Pipe -> ZcashAddress -> IO () - findPaidOrders c p z = do - paidTxs <- listTxs (c_nodeUser c) (c_nodePwd c) (addy z) 5 - case paidTxs of - Right txs -> do - let r = mkRegex ".*ZGo Order::([0-9a-fA-F]{24}).*" - let k = filter (isRelevant r) txs - let j = map (getOrderId r) k - mapM_ (recordPayment p (c_dbName config)) j - mapM_ (access p master (c_dbName config) . markOrderPaid) j - Left e -> print e - getOrderId :: Text.Regex.Regex -> ZcashTx -> (String, Double) - getOrderId re t = do - let reg = matchAllText re (T.unpack $ zmemo t) - if not (null reg) - then (fst $ head reg ! 1, zamount t) - else ("", 0) - recordPayment :: Pipe -> T.Text -> (String, Double) -> IO () - recordPayment p dbName x = do - o <- access p master dbName $ findOrderById (fst x) - let xOrder = o >>= (cast' . Doc) - case xOrder of - Nothing -> error "Failed to retrieve order from database" - Just xO -> - when - (not (qpaid xO) && - qexternalInvoice xO /= "" && qtotalZec xO == snd x) $ do - let sReg = mkRegex "(.*)-([a-fA-f0-9]{24})" - let sResult = matchAllText sReg (T.unpack $ qsession xO) - if not (null sResult) - then case fst $ head sResult ! 1 of - "Xero" -> do - xeroConfig <- access p master dbName findXero - let xC = xeroConfig >>= (cast' . Doc) - case xC of - Nothing -> error "Failed to read Xero config" - Just xConf -> do - requestXeroToken p dbName xConf "" (qaddress xO) - payXeroInvoice - p - dbName - (qexternalInvoice xO) - (qaddress xO) - (qtotal xO) - (qtotalZec xO) - "WC" -> do - let wOwner = fst $ head sResult ! 2 - wooT <- - access p master dbName $ findWooToken (read wOwner) - let wT = wooT >>= (cast' . Doc) - case wT of - Nothing -> error "Failed to read WooCommerce token" - Just wt -> do - let iReg = mkRegex "(.*)-(.*)-.*" - let iResult = - matchAllText - iReg - (T.unpack $ qexternalInvoice xO) - if not (null iResult) - then do - let wUrl = - E.decodeUtf8With lenientDecode . - B64.decodeLenient . C.pack $ - fst $ head iResult ! 1 - let iNum = fst $ head iResult ! 2 - payWooOrder - (T.unpack wUrl) - (C.pack iNum) - (C.pack $ maybe "" show (q_id xO)) - (C.pack . T.unpack $ w_token wt) - (C.pack . show $ qprice xO) - (C.pack . show $ qtotalZec xO) - else error - "Couldn't parse externalInvoice for WooCommerce" - _ -> putStrLn "Not an integration order" - else putStrLn "Not an integration order" + shopRecords <- access pipe master (c_dbName config) findActiveOwners + case shopRecords of + [] -> return () + _ -> do + let shops = cast' . Doc <$> shopRecords :: [Maybe Owner] + let validShopAddresses = map (maybe "" oaddress) $ filter isJust shops + mapM_ (findPaidOrders config pipe) validShopAddresses + where findPaidOrders :: Config -> Pipe -> T.Text -> IO () + findPaidOrders c p z = do + print z + paidTxs <- listTxs (c_nodeUser c) (c_nodePwd c) z 5 + case paidTxs of + Right txs -> do + let r = mkRegex ".*ZGo Order::([0-9a-fA-F]{24}).*" + let k = filter (isRelevant (c_confirmations c) r) txs + print k + let j = map (getOrderId r) k + mapM_ (recordPayment p (c_dbName config) z) j + Left e -> print e + getOrderId :: Text.Regex.Regex -> ZcashTx -> (String, Double) + getOrderId re t = do + let reg = matchAllText re (T.unpack $ zmemo t) + if not (null reg) + then (fst $ head reg ! 1, zamount t) + else ("", 0) + recordPayment :: + Pipe -> T.Text -> T.Text -> (String, Double) -> IO () + recordPayment p dbName z x = do + print x + o <- access p master dbName $ findOrderById (fst x) + let xOrder = o >>= (cast' . Doc) + case xOrder of + Nothing -> error "Failed to retrieve order from database" + Just xO -> + when + (not (qpaid xO) && qtotalZec xO == snd x && z == qaddress xO) $ do + let sReg = mkRegex "(.*)-([a-fA-f0-9]{24})" + let sResult = matchAllText sReg (T.unpack $ qsession xO) + if not (null sResult) + then case fst $ head sResult ! 1 of + "Xero" -> do + xeroConfig <- access p master dbName findXero + let xC = xeroConfig >>= (cast' . Doc) + case xC of + Nothing -> error "Failed to read Xero config" + Just xConf -> do + requestXeroToken + p + dbName + xConf + "" + (qaddress xO) + payXeroInvoice + p + dbName + (qexternalInvoice xO) + (qaddress xO) + (qtotal xO) + (qtotalZec xO) + liftIO $ + access p master dbName $ markOrderPaid x + "WC" -> do + let wOwner = fst $ head sResult ! 2 + wooT <- + access p master dbName $ + findWooToken $ Just (read wOwner) + let wT = wooT >>= (cast' . Doc) + case wT of + Nothing -> + error "Failed to read WooCommerce token" + Just wt -> do + let iReg = mkRegex "(.*)-(.*)-.*" + let iResult = + matchAllText + iReg + (T.unpack $ qexternalInvoice xO) + if not (null iResult) + then do + let wUrl = + E.decodeUtf8With lenientDecode . + B64.decodeLenient . C.pack $ + fst $ head iResult ! 1 + let iNum = fst $ head iResult ! 2 + payWooOrder + (T.unpack wUrl) + (C.pack iNum) + (C.pack $ maybe "" show (q_id xO)) + (C.pack . T.unpack $ w_token wt) + (C.pack . show $ qprice xO) + (C.pack . show $ qtotalZec xO) + liftIO $ + access p master dbName $ + markOrderPaid x + else error + "Couldn't parse externalInvoice for WooCommerce" + _ -> putStrLn "Not an integration order" + else liftIO $ access p master dbName $ markOrderPaid x -- | RPC methods -- | List addresses with viewing keys loaded @@ -1537,4 +1834,17 @@ expireProSessions pipe db = do access pipe master db $ removePro (psaddress z) access pipe master db $ closeProSession z +checkUser :: + (Action IO (Maybe Document) -> IO (Maybe Document)) + -> T.Text + -> IO (Maybe User) +checkUser run s = do + user <- run (findUser s) + return $ cast' . Doc =<< user + +generateToken :: IO String +generateToken = do + rngState <- newCryptoRNGState + runCryptoRNGT rngState $ randomString 24 "abcdef0123456789" + debug = flip trace diff --git a/src/ZGoTx.hs b/src/ZGoTx.hs index 9c95872..8f786b8 100644 --- a/src/ZGoTx.hs +++ b/src/ZGoTx.hs @@ -119,7 +119,6 @@ type Parser = Parsec Void T.Text pSession :: Parser MemoToken pSession = do - optional spaceChar string "ZGO" pay <- optional $ char 'p' string "::" @@ -142,13 +141,18 @@ pSaplingAddress = do pMsg :: Parser MemoToken pMsg = do - Msg . T.pack <$> - some (alphaNumChar <|> punctuationChar <|> charCategory OtherSymbol) + msg <- + some + (alphaNumChar <|> punctuationChar <|> symbolChar <|> + charCategory OtherSymbol) + pure $ Msg . T.pack $ msg pMemo :: Parser MemoToken pMemo = do - optional spaceChar - pSession <|> pSaplingAddress <|> pMsg + optional $ some spaceChar + t <- pSession <|> pSaplingAddress <|> pMsg + optional $ some spaceChar + return t isMemoToken :: T.Text -> MemoToken -> Bool isMemoToken kind t = diff --git a/stack.yaml b/stack.yaml index aff10dc..d65ab03 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,7 +17,7 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-20.19 +resolver: lts-20.23 #url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/4.yaml # User packages to be built. @@ -44,6 +44,16 @@ packages: extra-deps: - git: https://github.com/reach-sh/haskell-hexstring.git commit: 085c16fb21b9f856a435a3faab980e7e0b319341 + - git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git + commit: fef3d3af35a09db718cddb8fc9166b2d2691a744 + - git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git + commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05 + - git: https://github.com/well-typed/borsh.git + commit: d2fcfa159e0a844b1ec5e8ed3e232d4b380fa831 + - aeson-2.1.2.1@sha256:5b8d62a60963a925c4d123a46e42a8e235a32188522c9f119f64ac228c2612a7,6359 + - vector-0.13.0.0@sha256:fa5cac81a17a5af388716792e8b99c24b3b66770086756d0d8b23f8272a0244c,9112 + - generically-0.1.1 + - vector-algorithms-0.9.0.1 - blake3-0.2@sha256:d1146b9a51ccfbb0532780778b6d016a614e3d44c05d8c1923dde9a8be869045,2448 - crypto-rng-0.3.0.1@sha256:04f4ae75943ecad8b794950985054130f272d65a588b6b6528f56df0bfedc4dc,1565 # Override default flag values for local packages and extra-deps diff --git a/stack.yaml.lock b/stack.yaml.lock index 5a8e945..552f32f 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -15,6 +15,67 @@ packages: original: commit: 085c16fb21b9f856a435a3faab980e7e0b319341 git: https://github.com/reach-sh/haskell-hexstring.git +- completed: + commit: fef3d3af35a09db718cddb8fc9166b2d2691a744 + git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git + name: zcash-haskell + pantry-tree: + sha256: ec7782cf2646da17548d59af0ea98dcbaac1b6c2176258c696a7f508db6dbc21 + size: 1126 + version: 0.1.0 + original: + commit: fef3d3af35a09db718cddb8fc9166b2d2691a744 + git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git +- completed: + commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05 + git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git + name: foreign-rust + pantry-tree: + sha256: be2f6fc0fab58a90fec657bdb6bd0ccf0810c7dccfe95c78b85e174fae227e42 + size: 2315 + version: 0.1.0 + original: + commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05 + git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git +- completed: + commit: d2fcfa159e0a844b1ec5e8ed3e232d4b380fa831 + git: https://github.com/well-typed/borsh.git + name: borsh + pantry-tree: + sha256: 8335925f495a5a653fcb74b6b8bb18cd0b6b7fe7099a1686108704e6ab82f47b + size: 2268 + version: 0.3.0 + original: + commit: d2fcfa159e0a844b1ec5e8ed3e232d4b380fa831 + git: https://github.com/well-typed/borsh.git +- completed: + hackage: aeson-2.1.2.1@sha256:5b8d62a60963a925c4d123a46e42a8e235a32188522c9f119f64ac228c2612a7,6359 + pantry-tree: + sha256: 58d33beedd6e0ff79920c636d8a4295deb684b6e97c9b1ca94d3c780958d6302 + size: 82465 + original: + hackage: aeson-2.1.2.1@sha256:5b8d62a60963a925c4d123a46e42a8e235a32188522c9f119f64ac228c2612a7,6359 +- completed: + hackage: vector-0.13.0.0@sha256:fa5cac81a17a5af388716792e8b99c24b3b66770086756d0d8b23f8272a0244c,9112 + pantry-tree: + sha256: d2461d28022c8c0a91da08b579b1bff478f617102d2f5ef596cc5b28d14b8b6a + size: 4092 + original: + hackage: vector-0.13.0.0@sha256:fa5cac81a17a5af388716792e8b99c24b3b66770086756d0d8b23f8272a0244c,9112 +- completed: + hackage: generically-0.1.1@sha256:2b9b5efb6eea2fb65377565d53d85b0ccc5b37404fba4bef1d60277caa877e5e,1155 + pantry-tree: + sha256: 98a8fe89d516d3752a9cc0af22cfa652f098cc6613da080762b63aa1d596e56d + size: 233 + original: + hackage: generically-0.1.1 +- completed: + hackage: vector-algorithms-0.9.0.1@sha256:f3e5c6695529a94edf762117cafd91c989cb642ad3f8ca4014dbb13c8f6c2a20,3826 + pantry-tree: + sha256: aef389e57ae6020e5da719bee40aaf6cccf1c4d1e7743a85d30c9d8c25d170a0 + size: 1510 + original: + hackage: vector-algorithms-0.9.0.1 - completed: hackage: blake3-0.2@sha256:d1146b9a51ccfbb0532780778b6d016a614e3d44c05d8c1923dde9a8be869045,2448 pantry-tree: @@ -31,7 +92,7 @@ packages: hackage: crypto-rng-0.3.0.1@sha256:04f4ae75943ecad8b794950985054130f272d65a588b6b6528f56df0bfedc4dc,1565 snapshots: - completed: - sha256: 42f77c84b34f68c30c2cd0bf8c349f617a0f428264362426290847a6a2019b64 - size: 649618 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/19.yaml - original: lts-20.19 + sha256: 4c972e067bae16b95961dbfdd12e07f1ee6c8fffabbfa05c3d65100b03f548b7 + size: 650253 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/23.yaml + original: lts-20.23 diff --git a/test/Spec.hs b/test/Spec.hs index cbee780..5f17d11 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -13,10 +13,12 @@ import Data.Either import Data.Maybe import Data.SecureMem import qualified Data.Text as T +import qualified Data.Text.Encoding as E import Data.Time import Data.Time.Calendar import Data.Time.Clock import Data.Time.Clock.POSIX +import qualified Data.UUID as U import Database.MongoDB import Item import LangComponent @@ -32,6 +34,7 @@ import Test.Hspec.QuickCheck import Test.QuickCheck import Test.QuickCheck.Gen import Test.QuickCheck.Monadic +import Text.Megaparsec import User import Web.Scotty import WooCommerce @@ -53,7 +56,31 @@ main = do describe "hex strings" $ do prop "encoding and decoding are inverse" $ \x -> (decodeHexText . encodeHexText) x == x - describe "zToZGoTx" $ do + describe "zToZGoTx" $ + --prop "memo parsing" testMemoParser + do + it "parse ZecWallet memo" $ do + let m = + runParser + pZGoMemo + "Zecwalllet memo" + "ZGO::5d3d4494-51c0-432d-8495-050419957aea\nReply-To:\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + case m of + Left e -> putStrLn $ errorBundlePretty e + Right m' -> + m_session m' `shouldBe` + U.fromString "5d3d4494-51c0-432d-8495-050419957aea" + it "parse YWallet memo" $ do + let m = + runParser + pZGoMemo + "Ywallet memo" + "\128737MSG\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e\n\nZGO::ad8477d3-4fdd-4c97-90b2-76630b5f77e1" + case m of + Left e -> putStrLn $ errorBundlePretty e + Right m' -> + m_session m' `shouldBe` + U.fromString "ad8477d3-4fdd-4c97-90b2-76630b5f77e1" it "converts ZecWallet tx to ZGo tx" $ do let t = ZcashTx @@ -156,32 +183,13 @@ main = do getResponseStatus res `shouldBe` accepted202 describe "Price endpoint" $ do it "returns a price for an existing currency" $ do - req <- - testGet - "/api/price" - [ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd") - , ("currency", Just "usd") - ] + req <- testGet "/price" [("currency", Just "usd")] res <- httpJSON req getResponseStatus (res :: Response A.Value) `shouldBe` ok200 it "returns 204 when the currency is not supported" $ do - req <- - testGet - "/api/price" - [ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd") - , ("currency", Just "jpy") - ] + req <- testGet "/price" [("currency", Just "jpy")] res <- httpLBS req getResponseStatus res `shouldBe` noContent204 - it "returs 401 when the session is not valid" $ do - req <- - testGet - "/api/price" - [ ("session", Just "th7s1sa-fake-6u1d-7h47-1m4deuph3r3") - , ("currency", Just "usd") - ] - res <- httpLBS req - getResponseStatus res `shouldBe` unauthorized401 describe "Countries endpoint" $ do it "returns a list of countries" $ do req <- @@ -201,7 +209,7 @@ main = do it "returns a block number" $ do req <- testGet - "/api/blockheight" + "/blockheight" [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] res <- httpJSON req height (getResponseBody (res :: Response Block)) `shouldSatisfy` \x -> @@ -225,18 +233,32 @@ main = do req <- testGet "/api/xeroaccount" - [ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd") - , ("address", Just "Zaddy") - ] + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] res <- httpJSON req getResponseStatus (res :: Response A.Value) `shouldBe` ok200 - it "returns 401 with invalid session" $ do + it "reading returns 401 with invalid session" $ do req <- testGet "/api/xeroaccount" [("session", Just "fnelrkgnlyebrlvns82949")] res <- httpLBS req getResponseStatus res `shouldBe` unauthorized401 + it "setting returns 401 with invalid session" $ do + req <- + testPost + "/api/xeroaccount" + [("session", Just "fnelrkgnlyebrlvns82949")] + res <- httpLBS req + getResponseStatus res `shouldBe` unauthorized401 + it "setting succeeds with valid session" $ do + req <- + testPost + "/api/xeroaccount" + [ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd") + , ("code", Just "ZEC") + ] + res <- httpLBS req + getResponseStatus res `shouldBe` accepted202 describe "User endpoint" $ do it "returns a user for a session" $ do req <- @@ -252,14 +274,39 @@ main = do [("session", Just "suchafak-euui-dican-eve-nbelieveitca")] res <- httpLBS req getResponseStatus res `shouldBe` unauthorized401 - it "deletes user by id" $ do - req <- - testDelete - "/api/user/" - "6272a90f2b05a74cf1000003" - [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] - res <- httpLBS req - getResponseStatus res `shouldBe` ok200 + describe "delete" $ do + it "returns 401 when session is invalid" $ do + req <- + testDelete + "/api/user/" + "6272a90f2b05a74cf1000005" + [("session", Just "suchafak-euui-dican-eve-nbelieveitca")] + res <- httpLBS req + getResponseStatus res `shouldBe` unauthorized401 + it "returns 403 when user and session don't match" $ do + req <- + testDelete + "/api/user/" + "6272a90f2b05a74cf1000005" + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + res <- httpLBS req + getResponseStatus res `shouldBe` forbidden403 + it "returns 400 when user is invalid" $ do + req <- + testDelete + "/api/user/" + "000000000000000000000000" + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + res <- httpLBS req + getResponseStatus res `shouldBe` badRequest400 + it "deletes user by id" $ do + req <- + testDelete + "/api/user/" + "6272a90f2b05a74cf1000003" + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdaa")] + res <- httpLBS req + getResponseStatus res `shouldBe` ok200 describe "Owner endpoint" $ --prop "add owner" testOwnerAdd do @@ -294,8 +341,90 @@ main = do ] res <- httpLBS req getResponseStatus res `shouldBe` ok200 - describe "Order endpoints" $ do - prop "upsert order" testOrderAdd + describe "Order endpoints" $ + --prop "upsert order" testOrderAdd + do + it "adding order with bad session fails with 401" $ do + myTs <- liftIO getCurrentTime + let testOrder = + ZGoOrder + (Just (read "627ab3ea2b05a76be3000011")) + "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd" + myTs + False + "usd" + 102.0 + 0 + 0 + [] + False + "" + "" + "testToken4321" + req <- + testPostJson "/api/order" $ + A.object ["payload" A..= A.toJSON testOrder] + res <- + httpLBS $ + setRequestQueryString + [("session", Just "35bfb9c2-9ad2-fake-adda-99d63b8dcdcd")] + req + getResponseStatus res `shouldBe` unauthorized401 + it "adding order with mismatched session fails with 403" $ do + myTs <- liftIO getCurrentTime + let testOrder = + ZGoOrder + (Just (read "627ab3ea2b05a76be3000011")) + "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd" + myTs + False + "usd" + 102.0 + 0 + 0 + [] + False + "" + "" + "testToken4321" + req <- + testPostJson "/api/order" $ + A.object ["payload" A..= A.toJSON testOrder] + res <- + httpLBS $ + setRequestQueryString + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dfake")] + req + getResponseStatus res `shouldBe` forbidden403 + it "adding order with correct session succeeds" $ do + myTs <- liftIO getCurrentTime + let testOrder = + ZGoOrder + (Just (read "627ab3ea2b05a76be3000011")) + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" + "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd" + myTs + False + "usd" + 102.0 + 0 + 0 + [] + False + "" + "" + "testToken4321" + req <- + testPostJson "/api/order" $ + A.object ["payload" A..= A.toJSON testOrder] + res <- + httpLBS $ + setRequestQueryString + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + req + getResponseStatus res `shouldBe` created201 it "get order by session" $ do req <- testGet @@ -303,7 +432,7 @@ main = do [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] res <- httpJSON req getResponseStatus (res :: Response A.Value) `shouldBe` ok200 - it "get order by session fails when invalid" $ do + it "get order by session fails with bad session" $ do req <- testGet "/api/order" @@ -313,40 +442,49 @@ main = do it "get order by id" $ do req <- testGet - "/api/order/627ab3ea2b05a76be3000000" - [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + "/order/627ab3ea2b05a76be3000000" + [("token", Just "testToken1234")] res <- httpJSON req getResponseStatus (res :: Response A.Value) `shouldBe` ok200 - it "get order with wrong id" $ do + it "get order with invalid id fails with 400" $ do + req <- testGet "/order/6273hrb" [("token", Just "testToken1234")] + res <- httpLBS req + getResponseStatus res `shouldBe` badRequest400 + it "get order by id fails with bad token" $ do req <- testGet - "/api/order/6273hrb" - [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + "/order/627ab3ea2b05a76be3000000" + [("token", Just "wrongToken1234")] res <- httpLBS req - getResponseStatus res `shouldBe` noContent204 - it "get order by id fails with bad session" $ do - req <- - testGet - "/api/order/627ab3ea2b05a76be3000000" - [("session", Just "35bfb9c2-9ad2-4fe5-fake-99d63b8dcdcd")] - res <- httpLBS req - getResponseStatus res `shouldBe` unauthorized401 + getResponseStatus res `shouldBe` forbidden403 it "get all orders for owner" $ do req <- testGet "/api/allorders" - [ ("address", Just "Zaddy") - , ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd") - ] + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] res <- httpJSON req getResponseStatus (res :: Response A.Value) `shouldBe` ok200 it "get all orders for owner fails with bad session" $ do req <- testGet "/api/allorders" - [ ("address", Just "Zaddy") - , ("session", Just "35bfb9c2-9ad2-4fe5-fake-99d63b8dcdcd") - ] + [("session", Just "35bfb9c2-9ad2-4fe5-fake-99d63b8dcdcd")] + res <- httpLBS req + getResponseStatus res `shouldBe` unauthorized401 + it "delete order by id fails with mismatched session" $ do + req <- + testDelete + "/api/order/" + "627ab3ea2b05a76be3000000" + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dfake")] + res <- httpLBS req + getResponseStatus res `shouldBe` forbidden403 + it "delete order by id fails with bad session" $ do + req <- + testDelete + "/api/order/" + "627ab3ea2b05a76be3000000" + [("session", Just "35bfb9c2-9ad2-4fe5-fake-99d63b8dcdcd")] res <- httpLBS req getResponseStatus res `shouldBe` unauthorized401 it "delete order by id" $ do @@ -357,35 +495,98 @@ main = do [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] res <- httpLBS req getResponseStatus res `shouldBe` ok200 - it "delete order by id fails with bad session" $ do - req <- - testDelete - "/api/order/" - "627ab3ea2b05a76be3000000" - [("session", Just "35bfb9c2-9ad2-4fe5-fake-99d63b8dcdcd")] - res <- httpLBS req - getResponseStatus res `shouldBe` unauthorized401 describe "Item endpoint" $ do - prop "add item" testItemAdd - it "get items" $ do + it "adding item with bad session fails" $ do + let item = + Item + Nothing + "Table" + "Oak" + "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + 499.99 + req <- + testPostJson "/api/item" $ A.object ["payload" A..= A.toJSON item] + res <- + httpLBS $ + setRequestQueryString + [("session", Just "35bfb9c2-9ad2-fake-adda-99d63b8dcdcd")] + req + getResponseStatus res `shouldBe` unauthorized401 + it "adding item with good session succeeds" $ do + let item = + Item + (Just (read "627d7ba92b05a76be3000013")) + "Table" + "Oak" + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" + 499.99 + req <- + testPostJson "/api/item" $ A.object ["payload" A..= A.toJSON item] + res <- + httpLBS $ + setRequestQueryString + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + req + getResponseStatus res `shouldBe` created201 + it "get items with valid session succeeds" $ do req <- testGet "/api/items" - [ ("address", Just "Zaddy") - , ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd") - ] + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] res <- httpJSON req getResponseStatus (res :: Response A.Value) `shouldBe` ok200 - it "delete item" $ do + it "get items with invalid session returns 401" $ do req <- - testDelete - "/api/item/" - "627d7ba92b05a76be3000003" - [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + testGet + "/api/items" + [("session", Just "35bfb9c2-9ad2-4fe5-fake-99d63b8dcdcd")] res <- httpLBS req - getResponseStatus res `shouldBe` ok200 + getResponseStatus res `shouldBe` unauthorized401 + describe "delete item" $ do + it "returns 401 with invalid session and item ID" $ do + req <- + testDelete + "/api/item/" + "627d7ba92b05a76be3000003" + [("session", Just "35bfb9c2-9ad2-fake-adda-99d63b8dcdcd")] + res <- httpLBS req + getResponseStatus res `shouldBe` unauthorized401 + it "returns 403 when item ID doesn't belong to session" $ do + req <- + testDelete + "/api/item/" + "627d7ba92b05a76be3000003" + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + res <- httpLBS req + getResponseStatus res `shouldBe` forbidden403 + it "succeeds with valid session and item ID" $ do + req <- + testDelete + "/api/item/" + "627d7ba92b05a76be3000013" + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + res <- httpLBS req + getResponseStatus res `shouldBe` ok200 describe "WooCommerce endpoints" $ do - it "generate token" $ do + it "generate token with invalid session gives 401" $ do + req <- + testPost + "/api/wootoken" + [ ("ownerid", Just "627ad3492b05a76be3000001") + , ("session", Just "35bfb9c2-9ad2-fake-adda-99d63b8dcdcd") + ] + res <- httpLBS req + getResponseStatus res `shouldBe` unauthorized401 + it "generate token with mismatched session gives 403" $ do + req <- + testPost + "/api/wootoken" + [ ("ownerid", Just "627ad3492b05a76be3000001") + , ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dfake") + ] + res <- httpLBS req + getResponseStatus res `shouldBe` forbidden403 + it "generate token with valid session succeeds" $ do req <- testPost "/api/wootoken" @@ -394,6 +595,20 @@ main = do ] res <- httpLBS req getResponseStatus res `shouldBe` accepted202 + it "read token gives 401 with bad session" $ do + req <- + testGet + "/api/wootoken" + [("session", Just "35bfb9c2-9ad2-4fe5-fake-99d63b8dcdcd")] + res <- httpLBS req + getResponseStatus res `shouldBe` unauthorized401 + it "read token succeeds with valid session" $ do + req <- + testGet + "/api/wootoken" + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + res <- httpJSON req + getResponseStatus (res :: Response A.Value) `shouldBe` ok200 it "authenticate with incorrect owner" $ do req <- testPublicGet @@ -417,13 +632,17 @@ main = do res <- httpJSON req getResponseStatus (res :: Response A.Value) `shouldBe` accepted202 it "authenticate with correct token" $ do + req1 <- + testGet + "/api/wootoken" + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + res1 <- httpJSON req1 + let tk = getResponseBody (res1 :: Response WooToken) req <- testPublicGet "/auth" [ ("ownerid", Just "627ad3492b05a76be3000001") - , ( "token" - , Just - "0c1702c16c7bd7e075b8bb129b24888a5cc2181fa1eb4ce9190cfcb625ecf0ee") + , ("token", Just $ (E.encodeUtf8 . w_token) tk) , ("siteurl", Just "aHR0cHM6Ly93d3cudGVjcHJvdmFsLmNvbS8") ] res <- httpJSON req @@ -441,13 +660,17 @@ main = do res <- httpJSON req getResponseStatus (res :: Response A.Value) `shouldBe` accepted202 it "request order creation" $ do + req1 <- + testGet + "/api/wootoken" + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + res1 <- httpJSON req1 + let tk = getResponseBody (res1 :: Response WooToken) req <- testPublicGet "/woopayment" [ ("ownerid", Just "627ad3492b05a76be3000001") - , ( "token" - , Just - "0c1702c16c7bd7e075b8bb129b24888a5cc2181fa1eb4ce9190cfcb625ecf0ee") + , ("token", Just $ (E.encodeUtf8 . w_token) tk) , ("siteurl", Just "aHR0cHM6Ly93d3cudGVjcHJvdmFsLmNvbS8") , ("order_id", Just "1234") , ("currency", Just "usd") @@ -498,6 +721,63 @@ main = do ] res <- httpLBS req getResponseStatus res `shouldBe` noContent204 + describe "Viewing Key endpoint" $ do + let vk0 = + "zxviews1qwrw0jlxqqqqpqr9faepwqpgj09f0ee55mfwl60eumv6duk5pwncntweah0xdlhqrwre2fgmgersah9atx92z6pmxec8t32mpz59t47yuplkcdcaw3873aalv7e59xhwv846g9q9qjy0ypc68ceypg6pux490dr4snsc4m482l57rvnzj2lsh4f3dv6mltc75z72pypkx0dchwpumdwfuajstfhwulv30kjt5l0x7juwe523ufwz2xleplxf37gk2pfh59gmdjr4zsql4ga9p" + let vk1 = + "zxviews1qdjagrrpqqqqpq8es75mlu6rref0qyrstchf8dxzeygtsejwfqu8ckhwl2qj5m8am7lmupxk3vkvdjm8pawjpmesjfapvsqw96pa46c2z0kk7letrxf7mkltwz54fwpxc7kc79mm5kce3rwn5ssl009zwsra2spppwgrx25s9k5hq65f69l4jz2tjmqgy0pl49qmtaj3nudk6wglwe2hpa327hydlchtyq9av6wjd6hu68e04ahwk9a9n2kt0kj3nj99nue65awtu5cwwcpjs" + let vk2 = + "zxviews1qdjagrrpqqqqpq8es75mlufakef0qyrstchf8dxzeygtsejwfqu8ckhwl2qj5m8am7lmupxk3vkvdjm8pawjpmesjfapvsqw96pa46c2z0kk7letrxf7mkltwz54fwpxc7kc79mm5kce3rwn5ssl009zwsra2spppwgrx25s9k5hq65f69l4jz2tjmqgy0pl49qmtaj3nudk6wglwe2hpa327hydlchtyq9av6wjd6hu68e04ahwk9a9n2kt0kj3nj99nue65awtu5cwwcpjs" + it "returns 401 with bad session" $ do + req <- + testPostJson "/api/ownervk" $ + A.object ["payload" A..= (vk0 :: String)] + res <- + httpLBS $ + setRequestQueryString + [("session", Just "35bfb9c2-9ad2-4fe5-fake-99d63b8dcdcd")] + req + getResponseStatus res `shouldBe` unauthorized401 + it "returns 403 with mismatched session" $ do + req <- + testPostJson "/api/ownervk" $ + A.object ["payload" A..= (vk0 :: String)] + res <- + httpLBS $ + setRequestQueryString + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + req + getResponseStatus res `shouldBe` forbidden403 + it "returns 400 with malformed key" $ do + req <- + testPostJson "/api/ownervk" $ + A.object ["payload" A..= (vk2 :: String)] + res <- + httpLBS $ + setRequestQueryString + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + req + getResponseStatus res `shouldBe` badRequest400 + it "returns 400 with non-key valid bech32" $ do + req <- + testPostJson "/api/ownervk" $ + A.object ["payload" A..= ("bech321qqqsyrhqy2a" :: String)] + res <- + httpLBS $ + setRequestQueryString + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + req + getResponseStatus res `shouldBe` badRequest400 + it "succeeds with correct key" $ do + req <- + testPostJson "/api/ownervk" $ + A.object ["payload" A..= (vk1 :: String)] + res <- + httpLBS $ + setRequestQueryString + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + req + getResponseStatus res `shouldBe` created201 around handleDb $ describe "Database actions" $ do describe "authentication" $ do @@ -512,7 +792,7 @@ main = do doc <- access p master "test" $ findProSession - "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" doc `shouldNotBe` Nothing it "upsert to DB" $ const pending describe "Zcash prices" $ do @@ -573,7 +853,7 @@ main = do let myOrder = ZGoOrder (Just (read "627ab3ea2b05a76be3000001")) - "Zaddy" + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd" myTs False @@ -585,6 +865,7 @@ main = do False "" "" + "testToken1234" let ordTest = val myOrder case ordTest of Doc oT -> access p master "test" (insert_ "orders" oT) @@ -600,25 +881,26 @@ main = do Just o2 -> qpaid o2 `shouldBe` True describe "Xero data" $ do it "token is saved" $ \p -> do - let myToken = - XeroToken - Nothing - "Zaddy" - "superFakeToken123" - 1800 - "anotherSuperFakeToken" - (UTCTime (fromGregorian 2022 9 16) (secondsToDiffTime 0)) - (UTCTime (fromGregorian 2022 9 16) (secondsToDiffTime 0)) - "" - _ <- access p master "test" $ upsertToken myToken - t <- access p master "test" $ findToken "Zaddy" + t <- + access p master "test" $ + findToken + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" let t1 = (cast' . Doc) =<< t case t1 of Nothing -> True `shouldBe` False - Just t2 -> t_address t2 `shouldBe` "Zaddy" + Just t2 -> + t_address t2 `shouldBe` + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" it "code is saved" $ \p -> do - _ <- access p master "test" $ addAccCode "Zaddy" "ZEC" - t <- access p master "test" $ findToken "Zaddy" + _ <- + access p master "test" $ + addAccCode + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" + "ZEC" + t <- + access p master "test" $ + findToken + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" let t1 = (cast' . Doc) =<< t case t1 of Nothing -> True `shouldBe` False @@ -650,7 +932,7 @@ main = do let myUser = User (Just (read "6272a90f2b05a74cf1000002" :: ObjectId)) - "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcb" 1613487 "1234567" @@ -692,13 +974,13 @@ main = do findOne (select [ "address" =: - ("zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" :: T.Text) + ("zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" :: T.Text) ] "owners") let s = (cast' . Doc) =<< t let ownerPaid = maybe False opaid s ownerPaid `shouldBe` True - _ -> True `shouldBe` False `debug` "Failed parsing payment" + _ -> True `shouldBe` False --`debug` "Failed parsing payment" xit "owners are expired" $ \p -> do _ <- expireOwners p "test" now <- getCurrentTime @@ -717,7 +999,7 @@ main = do let myTx = ZGoTx Nothing - "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdca" 3 1613487 @@ -800,6 +1082,23 @@ testDelete endpoint par body = do setRequestPath (B.append endpoint par) defaultRequest return testRequest +testMemoParser :: T.Text -> T.Text -> T.Text -> Property +testMemoParser t1 t2 t3 = + monadicIO $ do + let res = + runParser pZGoMemo "Parser test" $ + t1 <> + " zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e " <> + t2 <> " ZGO::5d3d4494-51c0-432d-8495-050419957aea " <> t3 + case res of + Left e -> assert False `debug` errorBundlePretty e + Right zm -> + assert $ + U.fromString "5d3d4494-51c0-432d-8495-050419957aea" == m_session zm && + Just + "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" == + m_address zm + testOwnerAdd :: Owner -> Property testOwnerAdd o = monadicIO $ do @@ -848,6 +1147,14 @@ closeDbConnection = close handleDb :: (Pipe -> Expectation) -> IO () handleDb = bracket openDbConnection closeDbConnection +filterDocs :: Value -> Bool +filterDocs (Doc v) = True +filterDocs _ = False + +unwrapDoc :: Value -> Document +unwrapDoc (Doc v) = v +unwrapDoc _ = [] + startAPI :: Config -> IO () startAPI config = do putStrLn "Starting test server ..." @@ -860,54 +1167,39 @@ startAPI config = do _ <- access pipe master "test" (Database.MongoDB.delete (select [] "users")) _ <- access pipe master "test" (Database.MongoDB.delete (select [] "items")) _ <- access pipe master "test" (Database.MongoDB.delete (select [] "orders")) + _ <- + access pipe master "test" (Database.MongoDB.delete (select [] "xerotokens")) let myUser = User (Just (read "6272a90f2b05a74cf1000001" :: ObjectId)) - "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd" 1613487 "8ea140fbb30615d6cae383c4f62f3ad9afb10b804f63138d5b53990bd56e0162" False - _ <- - access - pipe - master - "test" - (insert_ - "users" - [ "address" =: uaddress myUser - , "_id" =: u_id myUser - , "session" =: usession myUser - , "blocktime" =: ublocktime myUser - , "pin" =: upin myUser - , "validated" =: uvalidated myUser - ]) let myUser1 = User (Just (read "6272a90f2b05a74cf1000003" :: ObjectId)) - "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" - "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd" + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" + "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdaa" 1613487 "8ea140fbb30615d6cae383c4f62f3ad9afb10b804f63138d5b53990bd56e0162" True - _ <- - access - pipe - master - "test" - (insert_ - "users" - [ "address" =: uaddress myUser1 - , "_id" =: u_id myUser1 - , "session" =: usession myUser1 - , "blocktime" =: ublocktime myUser1 - , "pin" =: upin myUser1 - , "validated" =: uvalidated myUser1 - ]) + let myUser2 = + User + (Just (read "6272a90f2b05a74cf1000005" :: ObjectId)) + "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3fake" + "35bfb9c2-9ad2-4fe5-adda-99d63b8dfake" + 1613487 + "8ea140fbb30615d6cae383c4f62f3ad9afb10b804f63138d5b53990bd56e0162" + True + let userList = + map unwrapDoc $ filter filterDocs $ val <$> [myUser, myUser1, myUser2] + _ <- access pipe master "test" (insertAll_ "users" userList) let myOwner = Owner (Just (read "627ad3492b05a76be3000001")) - "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" "Test shop" "usd" False @@ -931,17 +1223,48 @@ startAPI config = do False "" "" + let myOwner1 = + Owner + (Just (read "627ad3492b05a76be3000008")) + "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3fake" + "Test shop 2" + "usd" + False + 0 + False + 0 + "Roxy" + "Foo" + "roxy@zgo.cash" + "1 Main St" + "Mpls" + "Minnesota" + "55401" + "" + "missyfoo.io" + "United States" + True + False + False + (UTCTime (fromGregorian 2023 8 6) (secondsToDiffTime 0)) + False + "" + "" _ <- access pipe master "test" (Database.MongoDB.delete (select [] "owners")) let o = val myOwner case o of Doc d -> access pipe master "test" (insert_ "owners" d) _ -> fail "Couldn't save Owner in DB" + let o1 = val myOwner1 + case o1 of + Doc d1 -> access pipe master "test" (insert_ "owners" d1) + _ -> fail "Couldn't save Owner1 in DB" _ <- access pipe master "test" (Database.MongoDB.delete (select [] "orders")) myTs <- liftIO getCurrentTime let myOrder = ZGoOrder (Just (read "627ab3ea2b05a76be3000000")) - "Zaddy" + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd" myTs False @@ -953,6 +1276,7 @@ startAPI config = do False "" "" + "testToken1234" let ordTest = val myOrder case ordTest of Doc oT -> access pipe master "test" (insert_ "orders" oT) @@ -971,13 +1295,24 @@ startAPI config = do let proSession1 = ZGoProSession Nothing - "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" myTs False let proSessionTest = val proSession1 case proSessionTest of Doc pS1 -> access pipe master "test" (insert_ "prosessions" pS1) _ -> fail "Couldn't save test ZGoProSession in DB" + let myToken = + XeroToken + Nothing + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" + "superFakeToken123" + 1800 + "anotherSuperFakeToken" + (UTCTime (fromGregorian 2022 9 16) (secondsToDiffTime 0)) + (UTCTime (fromGregorian 2022 9 16) (secondsToDiffTime 0)) + "" + _ <- access pipe master "test" $ upsertToken myToken --let myWooToken = --WooToken --Nothing @@ -1006,7 +1341,8 @@ instance Arbitrary ZGoOrder where l <- arbitrary pd <- arbitrary eI <- arbitrary - ZGoOrder i a s ts c cur p t tZ l pd eI <$> arbitrary + sc <- arbitrary + ZGoOrder i a s ts c cur p t tZ l pd eI sc <$> arbitrary instance Arbitrary LineItem where arbitrary = do diff --git a/zgo-backend.cabal b/zgo-backend.cabal index 1450cc8..264cfbf 100644 --- a/zgo-backend.cabal +++ b/zgo-backend.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: zgo-backend -version: 1.5.0 +version: 1.6.0 synopsis: Haskell Back-end for the ZGo point-of-sale application description: Please see the README at category: Web @@ -78,6 +78,7 @@ library , wai-cors , wai-extra , warp-tls + , zcash-haskell default-language: Haskell2010 executable zgo-backend-exe @@ -175,10 +176,13 @@ test-suite zgo-backend-test , hspec-wai , http-conduit , http-types + , megaparsec , mongoDB , scotty , securemem , text , time + , uuid + , zcash-haskell , zgo-backend default-language: Haskell2010 diff --git a/zgo.cfg b/zgo.cfg index 1502706..d7db771 100644 --- a/zgo.cfg +++ b/zgo.cfg @@ -6,6 +6,7 @@ dbUser = "zgo" dbPassword = "zcashrules" nodeUser = "zecwallet" nodePassword = "rdsxlun6v4a" +confirmations = 100 port = 3000 tls = false certificate = "/path/to/cert.pem" diff --git a/zgotest.cfg b/zgotest.cfg index 4fc6230..a703b28 100644 --- a/zgotest.cfg +++ b/zgotest.cfg @@ -6,6 +6,7 @@ dbUser = "zgo" dbPassword = "zcashrules" nodeUser = "zecwallet" nodePassword = "rdsxlun6v4a" +confirmations = 100 port = 3000 tls = false certificate = "/path/to/cert.pem"