.gitignore

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

.gitmodules

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

cabal.project

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

package.yaml

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

src/ZGoBackend.hs

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

stack.yaml

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

stack.yaml.lock

@@ -1,109 +0,0 @@
-# This file was autogenerated by Stack.
-# You should not edit this file by hand.
-# For more information, please see the documentation at:
-#   https://docs.haskellstack.org/en/stable/lock_files
-
-packages:
-- completed:
-    commit: 085c16fb21b9f856a435a3faab980e7e0b319341
-    git: https://git.vergara.tech/Vergara_Tech/haskell-hexstring.git
-    name: hexstring
-    pantry-tree:
-      sha256: 9ecf67856f59dfb382b283eceb42e4fc1865935d1a7e59111556ed381c6a2ffd
-      size: 687
-    version: 0.11.1
-  original:
-    commit: 085c16fb21b9f856a435a3faab980e7e0b319341
-    git: https://git.vergara.tech/Vergara_Tech/haskell-hexstring.git
-- completed:
-    commit: dce171d83043fae0e5c771ff743d31c4ec19c1ae
-    git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git
-    name: zcash-haskell
-    pantry-tree:
-      sha256: 000770930e5d50596b82b38984d6e8ab94fd5345c7fcf3cc21682ef8e6348746
-      size: 1365
-    version: 0.3.0
-  original:
-    commit: dce171d83043fae0e5c771ff743d31c4ec19c1ae
-    git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git
-- completed:
-    commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05
-    git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git
-    name: foreign-rust
-    pantry-tree:
-      sha256: be2f6fc0fab58a90fec657bdb6bd0ccf0810c7dccfe95c78b85e174fae227e42
-      size: 2315
-    version: 0.1.0
-  original:
-    commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05
-    git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git
-- completed:
-    commit: d2fcfa159e0a844b1ec5e8ed3e232d4b380fa831
-    git: https://github.com/well-typed/borsh.git
-    name: borsh
-    pantry-tree:
-      sha256: 8335925f495a5a653fcb74b6b8bb18cd0b6b7fe7099a1686108704e6ab82f47b
-      size: 2268
-    version: 0.3.0
-  original:
-    commit: d2fcfa159e0a844b1ec5e8ed3e232d4b380fa831
-    git: https://github.com/well-typed/borsh.git
-- completed:
-    commit: 63bba3a6d30e5fd73c71fd7da752b2647d94f58e
-    git: https://git.vergara.tech/Vergara_Tech/mongodb.git
-    name: mongoDB
-    pantry-tree:
-      sha256: 63af9dc2612131fb5d1ea9d75b7055d5d0b28ca443149be1fb47c22bf204128f
-      size: 2297
-    version: 2.7.1.2
-  original:
-    commit: 63bba3a6d30e5fd73c71fd7da752b2647d94f58e
-    git: https://git.vergara.tech/Vergara_Tech/mongodb.git
-- completed:
-    hackage: aeson-2.1.2.1@sha256:5b8d62a60963a925c4d123a46e42a8e235a32188522c9f119f64ac228c2612a7,6359
-    pantry-tree:
-      sha256: 58d33beedd6e0ff79920c636d8a4295deb684b6e97c9b1ca94d3c780958d6302
-      size: 82465
-  original:
-    hackage: aeson-2.1.2.1@sha256:5b8d62a60963a925c4d123a46e42a8e235a32188522c9f119f64ac228c2612a7,6359
-- completed:
-    hackage: vector-0.13.0.0@sha256:fa5cac81a17a5af388716792e8b99c24b3b66770086756d0d8b23f8272a0244c,9112
-    pantry-tree:
-      sha256: d2461d28022c8c0a91da08b579b1bff478f617102d2f5ef596cc5b28d14b8b6a
-      size: 4092
-  original:
-    hackage: vector-0.13.0.0@sha256:fa5cac81a17a5af388716792e8b99c24b3b66770086756d0d8b23f8272a0244c,9112
-- completed:
-    hackage: generically-0.1.1@sha256:2b9b5efb6eea2fb65377565d53d85b0ccc5b37404fba4bef1d60277caa877e5e,1155
-    pantry-tree:
-      sha256: 98a8fe89d516d3752a9cc0af22cfa652f098cc6613da080762b63aa1d596e56d
-      size: 233
-  original:
-    hackage: generically-0.1.1
-- completed:
-    hackage: vector-algorithms-0.9.0.1@sha256:f3e5c6695529a94edf762117cafd91c989cb642ad3f8ca4014dbb13c8f6c2a20,3826
-    pantry-tree:
-      sha256: aef389e57ae6020e5da719bee40aaf6cccf1c4d1e7743a85d30c9d8c25d170a0
-      size: 1510
-  original:
-    hackage: vector-algorithms-0.9.0.1
-- completed:
-    hackage: blake3-0.2@sha256:d1146b9a51ccfbb0532780778b6d016a614e3d44c05d8c1923dde9a8be869045,2448
-    pantry-tree:
-      sha256: 0264ef3e7919e7b0d668c4153f6ce0d88e6965626b52d9dfd2cafd70309501d3
-      size: 1433
-  original:
-    hackage: blake3-0.2@sha256:d1146b9a51ccfbb0532780778b6d016a614e3d44c05d8c1923dde9a8be869045,2448
-- completed:
-    hackage: crypto-rng-0.3.0.1@sha256:04f4ae75943ecad8b794950985054130f272d65a588b6b6528f56df0bfedc4dc,1565
-    pantry-tree:
-      sha256: 1caccafe35d1ae3063f057c31188742a8e794f4f4e4530bab4019c0a514ee54f
-      size: 455
-  original:
-    hackage: crypto-rng-0.3.0.1@sha256:04f4ae75943ecad8b794950985054130f272d65a588b6b6528f56df0bfedc4dc,1565
-snapshots:
-- completed:
-    sha256: afd5ba64ab602cabc2d3942d3d7e7dd6311bc626dcb415b901eaf576cb62f0ea
-    size: 640060
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/22.yaml
-  original: lts-21.22

test/Spec.hs

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

zcash-haskell

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

zgo-backend.cabal

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