Merge branch 'security1'

Mantis Issue 28

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
 

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

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

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

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

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")
 

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

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")

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"

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"

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,56 +628,221 @@ 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
-      Nothing -> status noContent204
-      Just x -> do
-        let xConfig = cast' (Doc x)
-        case xConfig of
+    case cast' . Doc =<< xeroConfig of
       Nothing -> status noContent204
       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
-          Nothing -> do
-            status noContent204
-            text "Xero App credentials corrupted"
+        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 ok200
+            Web.Scotty.json
+              (object
+                 [ "reportType" .= (2 :: Integer)
+                 , "order" .= (Nothing :: Maybe ZGoOrder)
+                 , "shop" .= (Nothing :: Maybe String)
+                 ])
+          Just o' -> do
+            existingOrder <-
+              liftAndCatchIO $
+              run $
+              findXeroOrder
+                (oaddress o')
+                (xr_invNo invReq)
+                (xr_shortCode invReq)
+            case cast' . Doc =<< existingOrder of
+              Nothing -> do
                 res <-
                   liftAndCatchIO $
-              requestXeroToken pipe (c_dbName config) c "none" oAddress
+                  requestXeroToken pipe (c_dbName config) c "none" $ oaddress o'
                 if res
                   then do
                     resInv <-
                       liftAndCatchIO $
-                  getXeroInvoice pipe (c_dbName config) inv oAddress
+                      getXeroInvoice pipe (c_dbName config) (xr_invNo invReq) $
+                      oaddress o'
                     case resInv of
                       Nothing -> do
-                    status noContent204
-                    text "Xero invoice not found"
-                  Just xI -> do
                         status ok200
-                    Web.Scotty.json (object ["invdata" .= toJSON xI])
-              else status noContent204
+                        Web.Scotty.json
+                          (object
+                             [ "reportType" .= (2 :: Integer)
+                             , "order" .= (Nothing :: Maybe ZGoOrder)
+                             , "shop" .= (Nothing :: Maybe String)
+                             ])
+                      Just xI -> do
+                        if xi_type xI == "ACCREC"
+                          then if xi_status xI == "AUTHORISED"
+                                 then if xi_currency xI ==
+                                         T.toUpper (ocurrency o')
+                                        then if xi_total xI == xr_amount invReq
+                                               then do
+                                                 now <- liftIO getCurrentTime
+                                                 tk <- liftIO generateToken
+                                                 pr <-
+                                                   liftAndCatchIO $
+                                                   run
+                                                     (findPrice $
+                                                      T.unpack . ocurrency $ o')
+                                                 case parseZGoPrice =<< pr of
+                                                   Nothing -> do
+                                                     status ok200
+                                                     Web.Scotty.json
+                                                       (object
+                                                          [ "reportType" .=
+                                                            (7 :: Integer)
+                                                          , "order" .=
+                                                            (Nothing :: Maybe ZGoOrder)
+                                                          , "shop" .=
+                                                            (Nothing :: Maybe String)
+                                                          ])
+                                                   Just cp -> do
+                                                     let newOrder =
+                                                           ZGoOrder
+                                                             Nothing
+                                                             (oaddress o')
+                                                             ("Xero-" <>
+                                                              maybe
+                                                                ""
+                                                                (T.pack . show)
+                                                                (o_id o'))
+                                                             now
+                                                             True
+                                                             (ocurrency o')
+                                                             (price cp)
+                                                             (xi_total xI)
+                                                             (xi_total xI /
+                                                              price cp)
+                                                             [ LineItem
+                                                                 1
+                                                                 ("Invoice from " <>
+                                                                  oname o' <>
+                                                                  " [" <>
+                                                                  xi_number xI <>
+                                                                  "]")
+                                                                 (xi_total xI)
+                                                             ]
+                                                             False
+                                                             (xi_number xI)
+                                                             (xr_shortCode
+                                                                invReq)
+                                                             (T.pack tk)
+                                                     _ <-
+                                                       liftAndCatchIO $
+                                                       run $
+                                                       upsertOrder newOrder
+                                                     finalOrder <-
+                                                       liftAndCatchIO $
+                                                       run $
+                                                       findXeroOrder
+                                                         (oaddress o')
+                                                         (xi_number xI)
+                                                         (xr_shortCode invReq)
+                                                     case cast' . Doc =<<
+                                                          finalOrder of
+                                                       Nothing -> do
+                                                         status
+                                                           internalServerError500
+                                                         text
+                                                           "Unable to save order to DB"
+                                                       Just fO -> do
+                                                         status created201
+                                                         Web.Scotty.json
+                                                           (object
+                                                              [ "reportType" .=
+                                                                (0 :: Integer)
+                                                              , "order" .=
+                                                                toJSON
+                                                                  (fO :: ZGoOrder)
+                                                              , "shop" .=
+                                                                oname o'
+                                                              ])
+                                               else do
+                                                 status ok200
+                                                 Web.Scotty.json
+                                                   (object
+                                                      [ "reportType" .=
+                                                        (8 :: Integer)
+                                                      , "order" .=
+                                                        (Nothing :: Maybe ZGoOrder)
+                                                      , "shop" .=
+                                                        (Nothing :: Maybe String)
+                                                      ])
+                                        else do
+                                          status ok200
+                                          Web.Scotty.json
+                                            (object
+                                               [ "reportType" .= (7 :: Integer)
+                                               , "order" .=
+                                                 (Nothing :: Maybe ZGoOrder)
+                                               , "shop" .=
+                                                 (Nothing :: Maybe String)
+                                               ])
+                                 else do
+                                   status ok200
+                                   Web.Scotty.json
+                                     (object
+                                        [ "reportType" .= (6 :: Integer)
+                                        , "order" .= (Nothing :: Maybe ZGoOrder)
+                                        , "shop" .= (Nothing :: Maybe String)
+                                        ])
+                          else do
+                            status ok200
+                            Web.Scotty.json
+                              (object
+                                 [ "reportType" .= (5 :: Integer)
+                                 , "order" .= (Nothing :: Maybe ZGoOrder)
+                                 , "shop" .= (Nothing :: Maybe String)
+                                 ])
+                  else do
+                    status ok200
+                    Web.Scotty.json
+                      (object
+                         [ "reportType" .= (1 :: Integer)
+                         , "order" .= (Nothing :: Maybe ZGoOrder)
+                         , "shop" .= (Nothing :: Maybe String)
+                         ])
+              Just eO -> do
+                status created201
+                Web.Scotty.json
+                  (object
+                     [ "reportType" .= (0 :: Integer)
+                     , "order" .= toJSON (eO :: ZGoOrder)
+                     , "shop" .= oname o'
+                     ])
   -- Get the xeroaccount code
   get "/api/xeroaccount" $ do
-    oAdd <- param "address"
-    res <- liftAndCatchIO $ run (findToken oAdd)
+    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
@@ -685,14 +855,27 @@ routes pipe config = do
                  ])
   -- Save the xeroaccount code
   post "/api/xeroaccount" $ do
-    oAdd <- param "address"
+    session <- param "session"
     c <- param "code"
+    user <- liftAndCatchIO $ run (findUser session)
+    case cast' . Doc =<< user of
+      Nothing -> status unauthorized401
+      Just u -> do
+        let oAdd = uaddress u
         liftAndCatchIO $ run (addAccCode oAdd c)
         status accepted202
   -- Get the WooCommerce token
   get "/api/wootoken" $ do
-    oid <- param "ownerid"
-    res <- liftAndCatchIO $ run (findWooToken (read oid))
+    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
@@ -706,19 +889,27 @@ routes pipe config = do
                      ])
   post "/api/wootoken" $ do
     oid <- param "ownerid"
+    session <- param "session"
+    user <- liftAndCatchIO $ run (findUser session)
+    case cast' . Doc =<< user of
+      Nothing -> status unauthorized401
+      Just u -> do
         res <- liftAndCatchIO $ run (findOwnerById oid)
-    let o1 = cast' . Doc =<< res
-    case o1 of
-      Nothing -> status noContent204
+        case cast' . Doc =<< res of
+          Nothing -> status badRequest400
           Just o -> do
-        liftAndCatchIO $ run (generateWooToken o)
+            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
+        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 noContent204
+              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,10 +1205,58 @@ 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)
+    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
@@ -1026,22 +1264,40 @@ routes pipe config = do
             status ok200
             Web.Scotty.json
               (object
-             ["message" .= ("Items found!" :: String), "items" .= toJSON pItems])
+                 [ "message" .= ("Items found!" :: String)
+                 , "items" .= toJSON pItems
+                 ])
     --Upsert item
   post "/api/item" $ do
     i <- jsonData
+    session <- param "session"
+    user <- liftAndCatchIO $ run (findUser session)
+    case cast' . Doc =<< user of
+      Nothing -> status forbidden403
+      Just u -> do
         let q = payload (i :: Payload Item)
+        if uaddress u == iowner q
+          then do
             _ <- liftAndCatchIO $ run (upsertItem q)
             status created201
+          else status forbidden403
     --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
+    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 noContent204
+              else status forbidden403
     --Get price for Zcash
   get "/price" $ do
     curr <- param "currency"
@@ -1057,8 +1313,12 @@ routes pipe config = do
              ])
     --Get all closed orders for the address
   get "/api/allorders" $ do
-    addr <- param "address"
-    myOrders <- liftAndCatchIO $ run (findAllOrders addr)
+    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
@@ -1070,26 +1330,31 @@ routes pipe config = do
                  , "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
+            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 noContent204
+              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)
+    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"
+    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,19 +1575,24 @@ 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 ()
+  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
-      paidTxs <- listTxs (c_nodeUser c) (c_nodePwd c) (addy z) 5
+              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 r) txs
+                  let k = filter (isRelevant (c_confirmations c) r) txs
+                  print k
                   let j = map (getOrderId r) k
-          mapM_ (recordPayment p (c_dbName config)) j
-          mapM_ (access p master (c_dbName config) . markOrderPaid) j
+                  mapM_ (recordPayment p (c_dbName config) z) j
                 Left e -> print e
             getOrderId :: Text.Regex.Regex -> ZcashTx -> (String, Double)
             getOrderId re t = do
@@ -1316,16 +1600,17 @@ scanPayments config pipe = do
               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
+            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) &&
-             qexternalInvoice xO /= "" && qtotalZec xO == snd x) $ do
+                    (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)
@@ -1336,7 +1621,12 @@ scanPayments config pipe = do
                                case xC of
                                  Nothing -> error "Failed to read Xero config"
                                  Just xConf -> do
-                           requestXeroToken p dbName xConf "" (qaddress xO)
+                                   requestXeroToken
+                                     p
+                                     dbName
+                                     xConf
+                                     ""
+                                     (qaddress xO)
                                    payXeroInvoice
                                      p
                                      dbName
@@ -1344,13 +1634,17 @@ scanPayments config pipe = do
                                      (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 (read wOwner)
+                                 access p master dbName $
+                                 findWooToken $ Just (read wOwner)
                                let wT = wooT >>= (cast' . Doc)
                                case wT of
-                         Nothing -> error "Failed to read WooCommerce token"
+                                 Nothing ->
+                                   error "Failed to read WooCommerce token"
                                  Just wt -> do
                                    let iReg = mkRegex "(.*)-(.*)-.*"
                                    let iResult =
@@ -1371,10 +1665,13 @@ scanPayments config pipe = do
                                          (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 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

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 =

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

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

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,12 +274,37 @@ main = do
                 [("session", Just "suchafak-euui-dican-eve-nbelieveitca")]
             res <- httpLBS req
             getResponseStatus res `shouldBe` unauthorized401
+          describe "delete" $ do
+            it "returns 401 when session is invalid" $ do
+              req <-
+                testDelete
+                  "/api/user/"
+                  "6272a90f2b05a74cf1000005"
+                  [("session", Just "suchafak-euui-dican-eve-nbelieveitca")]
+              res <- httpLBS req
+              getResponseStatus res `shouldBe` unauthorized401
+            it "returns 403 when user and session don't match" $ do
+              req <-
+                testDelete
+                  "/api/user/"
+                  "6272a90f2b05a74cf1000005"
+                  [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
+              res <- httpLBS req
+              getResponseStatus res `shouldBe` forbidden403
+            it "returns 400 when user is invalid" $ do
+              req <-
+                testDelete
+                  "/api/user/"
+                  "000000000000000000000000"
+                  [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
+              res <- httpLBS req
+              getResponseStatus res `shouldBe` badRequest400
             it "deletes user by id" $ do
               req <-
                 testDelete
                   "/api/user/"
                   "6272a90f2b05a74cf1000003"
-                [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
+                  [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdaa")]
               res <- httpLBS req
               getResponseStatus res `shouldBe` ok200
         describe "Owner endpoint" $
@@ -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 <-
+              testGet
+                "/api/items"
+                [("session", Just "35bfb9c2-9ad2-4fe5-fake-99d63b8dcdcd")]
+            res <- httpLBS req
+            getResponseStatus res `shouldBe` unauthorized401
+          describe "delete item" $ do
+            it "returns 401 with invalid session and item ID" $ do
+              req <-
+                testDelete
+                  "/api/item/"
+                  "627d7ba92b05a76be3000003"
+                  [("session", Just "35bfb9c2-9ad2-fake-adda-99d63b8dcdcd")]
+              res <- httpLBS req
+              getResponseStatus res `shouldBe` unauthorized401
+            it "returns 403 when item ID doesn't belong to session" $ do
               req <-
                 testDelete
                   "/api/item/"
                   "627d7ba92b05a76be3000003"
                   [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
               res <- httpLBS req
+              getResponseStatus res `shouldBe` forbidden403
+            it "succeeds with valid session and item ID" $ do
+              req <-
+                testDelete
+                  "/api/item/"
+                  "627d7ba92b05a76be3000013"
+                  [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
+              res <- httpLBS req
               getResponseStatus res `shouldBe` ok200
         describe "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

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 <https://git.vergara.tech/Vergara_Tech//zgo-backend#readme>
 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

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"

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"