diff --git a/.gitignore b/.gitignore index e909f1e..c368d45 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,2 @@ .stack-work/ -dist-newstyle/ -*~ +*~ \ No newline at end of file diff --git a/.gitmodules b/.gitmodules deleted file mode 100644 index b77a9e5..0000000 --- a/.gitmodules +++ /dev/null @@ -1,4 +0,0 @@ -[submodule "zcash-haskell"] - path = zcash-haskell - url = https://git.vergara.tech/Vergara_Tech/zcash-haskell - branch = milestone2 diff --git a/CHANGELOG.md b/CHANGELOG.md index 30619dc..d87c1a2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,14 +4,6 @@ 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.8.1] - -### Changed - -- Changed license to MIT -- Updated to Haskell LTS 21.22 -- Update to new version of `zcash-haskell` - ## [1.8.0] ### Added diff --git a/COPYING b/COPYING new file mode 100644 index 0000000..2835367 --- /dev/null +++ b/COPYING @@ -0,0 +1,7 @@ +Copyright (c) 2022 Vergara Technologies LLC + +This package ("Original Work") is licensed under the terms of the Bootstrap +Open Source License, version 1.0, or at your option, any later version +("BOSL"). See the file ./LICENSE for the terms of the Bootstrap Open Source +Licence, version 1.0. + diff --git a/LICENSE b/LICENSE index 2f0193a..4eb1836 100644 --- a/LICENSE +++ b/LICENSE @@ -1,21 +1,178 @@ -MIT License +Copyright (c) 2023 Vergara Technologies LLC -Copyright (c) 2022-2024 Vergara Technologies LLC +======================================================= +Bootstrap Open Source Licence ("BOSL") v. 1.0 +======================================================= +This Bootstrap Open Source Licence (the "License") applies to any original work +of authorship (the "Original Work") whose owner (the "Licensor") has placed the +following licensing notice adjacent to the copyright notice for the Original +Work: -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: +*Licensed under the Bootstrap Open Source Licence version 1.0* -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. +1. **Grant of Copyright License.** Licensor grants You a worldwide, + royalty-free, non-exclusive, sublicensable license, for the duration of the + copyright in the Original Work, to do the following: -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -SOFTWARE. + a. to reproduce the Original Work in copies, either alone or as part of + a collective work; + + b. to translate, adapt, alter, transform, modify, or arrange the + Original Work, thereby creating derivative works ("Derivative Works") + based upon the Original Work; + + c. to distribute or communicate copies of the Original Work and + Derivative Works to the public, provided that prior to any such + distribution or communication You first place a machine-readable copy + of the Source Code of the Original Work and such Derivative Works that + You intend to distribute or communicate in an information repository + reasonably calculated to permit inexpensive and convenient access + thereto by the public (“Information Repository”) for as long as You + continue to distribute or communicate said copies, accompanied by an + irrevocable offer to license said copies to the public free of charge + under this License, said offer valid starting no later than 12 months + after You first distribute or communicate said copies; + + d. to perform the Original Work publicly; and + + e. to display the Original Work publicly. + +2. **Grant of Patent License.** Licensor grants You a worldwide, royalty-free, +non-exclusive, sublicensable license, under patent claims owned or controlled +by the Licensor that are embodied in the Original Work as furnished by the +Licensor, for the duration of the patents, to make, use, sell, offer for sale, +have made, and import the Original Work and Derivative Works. + +3. **Grant of Source Code License.** The "Source Code" for a work means the +preferred form of the work for making modifications to it and all available +documentation describing how to modify the work. Licensor agrees to provide a +machine-readable copy of the Source Code of the Original Work along with each +copy of the Original Work that Licensor distributes. Licensor reserves the +right to satisfy this obligation by placing a machine-readable copy of said +Source Code in an Information Repository for as long as Licensor continues to +distribute the Original Work. + +4. **Exclusions From License Grant.** Neither the names of Licensor, nor the +names of any contributors to the Original Work, nor any of their trademarks or +service marks, may be used to endorse or promote products derived from this +Original Work without express prior permission of the Licensor. Except as +expressly stated herein, nothing in this License grants any license to +Licensor's trademarks, copyrights, patents, trade secrets or any other +intellectual property. No patent license is granted to make, use, sell, offer +for sale, have made, or import embodiments of any patent claims other than the +licensed claims defined in Section 2. No license is granted to the trademarks +of Licensor even if such marks are included in the Original Work. Nothing in +this License shall be interpreted to prohibit Licensor from licensing under +terms different from this License any Original Work that Licensor otherwise +would have a right to license. + +5. **External Deployment.** The term "External Deployment" means the use, +distribution, or communication of the Original Work or Derivative Works in any +way such that the Original Work or Derivative Works may be used by anyone other +than You, whether those works are distributed or communicated to those persons +or made available as an application intended for use over a network. As an +express condition for the grants of license hereunder, You must treat any +External Deployment by You of the Original Work or a Derivative Work as a +distribution under section 1(c). + +6. **Attribution Rights.** You must retain, in the Source Code of any +Derivative Works that You create, all copyright, patent, or trademark notices +from the Source Code of the Original Work, as well as any notices of licensing +and any descriptive text identified therein as an "Attribution Notice." You +must cause the Source Code for any Derivative Works that You create to carry a +prominent Attribution Notice reasonably calculated to inform recipients that +You have modified the Original Work. + +7. **Warranty of Provenance and Disclaimer of Warranty.** Licensor warrants +that the copyright in and to the Original Work and the patent rights granted +herein by Licensor are owned by the Licensor or are sublicensed to You under +the terms of this License with the permission of the contributor(s) of those +copyrights and patent rights. Except as expressly stated in the immediately +preceding sentence, the Original Work is provided under this License on an "AS +IS" BASIS and WITHOUT WARRANTY, either express or implied, including, without +limitation, the warranties of non-infringement, merchantability or fitness for +a particular purpose. THE ENTIRE RISK AS TO THE QUALITY OF THE ORIGINAL WORK IS +WITH YOU. This DISCLAIMER OF WARRANTY constitutes an essential part of this +License. No license to the Original Work is granted by this License except +under this disclaimer. + +8. **Limitation of Liability.** Under no circumstances and under no legal +theory, whether in tort (including negligence), contract, or otherwise, shall +the Licensor be liable to anyone for any indirect, special, incidental, or +consequential damages of any character arising as a result of this License or +the use of the Original Work including, without limitation, damages for loss of +goodwill, work stoppage, computer failure or malfunction, or any and all other +commercial damages or losses. This limitation of liability shall not apply to +the extent applicable law prohibits such limitation. + +9. **Acceptance and Termination.** If, at any time, You expressly assented to +this License, that assent indicates your clear and irrevocable acceptance of +this License and all of its terms and conditions. If You distribute or +communicate copies of the Original Work or a Derivative Work, You must make a +reasonable effort under the circumstances to obtain the express assent of +recipients to the terms of this License. This License conditions your rights to +undertake the activities listed in Section 1, including your right to create +Derivative Works based upon the Original Work, and doing so without honoring +these terms and conditions is prohibited by copyright law and international +treaty. Nothing in this License is intended to affect copyright exceptions and +limitations (including 'fair use' or 'fair dealing'). This License shall +terminate immediately and You may no longer exercise any of the rights granted +to You by this License upon your failure to honor the conditions in Section +1(c). + +10. **Termination for Patent Action.** This License shall terminate +automatically and You may no longer exercise any of the rights granted to You +by this License as of the date You commence an action, including a cross-claim +or counterclaim, against Licensor or any licensee alleging that the Original +Work infringes a patent. This termination provision shall not apply for an +action alleging patent infringement by combinations of the Original Work with +other software or hardware. + +11. **Jurisdiction, Venue and Governing Law.** Any action or suit relating to +this License may be brought only in the courts of a jurisdiction wherein the +Licensor resides or in which Licensor conducts its primary business, and under +the laws of that jurisdiction excluding its conflict-of-law provisions. The +application of the United Nations Convention on Contracts for the International +Sale of Goods is expressly excluded. Any use of the Original Work outside the +scope of this License or after its termination shall be subject to the +requirements and penalties of copyright or patent law in the appropriate +jurisdiction. This section shall survive the termination of this License. + +12. **Attorneys' Fees.** In any action to enforce the terms of this License or +seeking damages relating thereto, the prevailing party shall be entitled to +recover its costs and expenses, including, without limitation, reasonable +attorneys' fees and costs incurred in connection with such action, including +any appeal of such action. This section shall survive the termination of this +License. + +13. **Miscellaneous.** If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent necessary to +make it enforceable. + +14. **Definition of "You" in This License.** "You" throughout this License, +whether in upper or lower case, means an individual or a legal entity +exercising rights under, and complying with all of the terms of, this License. +For legal entities, "You" includes any entity that controls, is controlled by, +or is under common control with you. For purposes of this definition, "control" +means (i) the power, direct or indirect, to cause the direction or management +of such entity, whether by contract or otherwise, or (ii) ownership of fifty +percent (50%) or more of the outstanding shares, or (iii) beneficial ownership +of such entity. + +15. **Right to Use.** You may use the Original Work in all ways not otherwise +restricted or conditioned by this License or by law, and Licensor promises not +to interfere with or be responsible for such uses by You. + +16. **Modification of This License.** This License is Copyright © 2007 Zooko +Wilcox-O'Hearn. Permission is granted to copy, distribute, or communicate this +License without modification. Nothing in this License permits You to modify +this License as applied to the Original Work or to Derivative Works. However, +You may modify the text of this License and copy, distribute or communicate +your modified version (the "Modified License") and apply it to other original +works of authorship subject to the following conditions: (i) You may not +indicate in any way that your Modified License is the "Bootstrap Open Source +Licence" or "BOSL" and you may not use those names in the name of your Modified +License; and (ii) You must replace the notice specified in the first paragraph +above with the notice "Licensed under " or with +a notice of your own that is not confusingly similar to the notice in this +License. diff --git a/cabal.project b/cabal.project deleted file mode 100644 index 836a722..0000000 --- a/cabal.project +++ /dev/null @@ -1,16 +0,0 @@ -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 - diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..4f4d860 --- /dev/null +++ b/package.yaml @@ -0,0 +1,167 @@ +name: zgo-backend +version: 1.8.0 +git: "https://git.vergara.tech/Vergara_Tech/zgo-backend" +license: BOSL +author: "Rene Vergara" +maintainer: "rene@vergara.network" +copyright: "Copyright (c) 2023 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 + +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 diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index ef88e2e..da23781 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -15,6 +15,7 @@ import Control.Monad.IO.Class import Crypto.RNG (newCryptoRNGState, runCryptoRNGT) import Crypto.RNG.Utils (randomString) import Data.Aeson +import Data.Aeson (decodeFileStrict) import Data.Array import qualified Data.Bson as B import qualified Data.ByteArray as BA @@ -62,7 +63,7 @@ import Text.Megaparsec (runParser) import Text.Regex import Text.Regex.Base import User -import Web.Scotty hiding (getResponseStatus) +import Web.Scotty import WooCommerce import Xero import ZGoTx @@ -91,8 +92,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 +102,14 @@ instance FromJSON Block where -- | Type to model a Zcash shielded transaction data ZcashTx = ZcashTx - { ztxid :: !HexString - , zamount :: !Double - , zamountZat :: !Integer - , zblockheight :: !Integer - , zblocktime :: !Integer - , zchange :: !Bool - , zconfirmations :: !Integer - , zmemo :: !T.Text + { ztxid :: T.Text + , zamount :: Double + , zamountZat :: Integer + , zblockheight :: Integer + , zblocktime :: Integer + , zchange :: Bool + , zconfirmations :: Integer + , zmemo :: T.Text } deriving (Show, Generic) instance FromJSON ZcashTx where @@ -155,14 +156,14 @@ instance Arbitrary ZcashTx where bt <- arbitrary c <- arbitrary cm <- arbitrary - ZcashTx (HexString a) aZ t bh bt c cm <$> arbitrary + ZcashTx 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 +246,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 +270,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 . fromRawBytes $ E.encodeUtf8 t +encodeHexText t = T.unpack . toText . fromBytes $ 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 +305,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 (toText t) m + ZGoTx Nothing nAddy sess conf bt a t m else do if not (null reg2) then do let sess = T.pack (fst $ head reg2 ! 1) - ZGoTx Nothing "" sess conf bt a (toText t) m + ZGoTx Nothing "" sess conf bt a 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 (toText t) m - else ZGoTx Nothing "" "" conf bt a (toText t) m + ZGoTx Nothing nAddy sess conf bt a t m + else ZGoTx Nothing "" "" conf bt a 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 . toText $ t) m + let zM = runParser pZGoMemo (T.unpack t) m case zM of Right zM' -> do print zM' @@ -333,7 +334,7 @@ zToZGoTx' config pipe (ZcashTx t a aZ bh bt c conf m) = do conf bt a - (toText t) + t m if m_payment zM' then upsertPayment pipe (c_dbName config) tx @@ -342,10 +343,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 +409,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,7 +470,6 @@ 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 ] @@ -608,18 +608,19 @@ routes pipe config = do middleware $ zgoAuth pipe $ c_dbName config --Get list of countries for UI get "/api/countries" $ do - countries <- liftIO $ run listCountries - if not (null countries) - then do + countries <- liftAndCatchIO $ run listCountries + case countries of + [] -> do + status noContent204 + _ -> 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 <- liftIO $ run findXero + xeroConfig <- liftAndCatchIO $ run findXero case xeroConfig of Nothing -> status noContent204 Just x -> do @@ -634,10 +635,10 @@ routes pipe config = do , "xeroConfig" .= toJSON (c :: Xero) ]) get "/api/xerotoken" $ do - code <- queryParam "code" - session <- queryParam "session" - user <- liftIO $ run (findUser session) - xeroConfig <- liftIO $ run findXero + code <- param "code" + session <- param "session" + user <- liftAndCatchIO $ run (findUser session) + xeroConfig <- liftAndCatchIO $ run findXero case cast' . Doc =<< xeroConfig of Nothing -> status noContent204 Just c -> do @@ -645,14 +646,14 @@ routes pipe config = do Nothing -> status unauthorized401 Just u -> do res <- - liftIO $ + liftAndCatchIO $ requestXeroToken pipe (c_dbName config) c code $ uaddress u if res then status ok200 else status noContent204 post "/invdata" $ do invData <- jsonData - xeroConfig <- liftIO $ run findXero + xeroConfig <- liftAndCatchIO $ run findXero let invReq = payload (invData :: Payload XeroInvoiceRequest) case cast' . Doc =<< xeroConfig of Nothing -> do @@ -664,7 +665,7 @@ routes pipe config = do , "shop" .= (Nothing :: Maybe String) ]) Just c -> do - o <- liftIO $ run $ findOwnerById $ xr_owner invReq + o <- liftAndCatchIO $ run $ findOwnerById $ xr_owner invReq case cast' . Doc =<< o of Nothing -> do status ok200 @@ -676,7 +677,7 @@ routes pipe config = do ]) Just o' -> do existingOrder <- - liftIO $ + liftAndCatchIO $ run $ findXeroOrder (oaddress o') @@ -685,12 +686,12 @@ routes pipe config = do case cast' . Doc =<< existingOrder of Nothing -> do res <- - liftIO $ + liftAndCatchIO $ requestXeroToken pipe (c_dbName config) c "none" $ oaddress o' if res then do resInv <- - liftIO $ + liftAndCatchIO $ getXeroInvoice pipe (c_dbName config) (xr_invNo invReq) $ oaddress o' case resInv of @@ -712,7 +713,7 @@ routes pipe config = do now <- liftIO getCurrentTime tk <- liftIO generateToken pr <- - liftIO $ + liftAndCatchIO $ run (findPrice $ T.unpack . ocurrency $ o') @@ -765,11 +766,11 @@ routes pipe config = do 0 0 _ <- - liftIO $ + liftAndCatchIO $ run $ upsertOrder newOrder 0 0 finalOrder <- - liftIO $ + liftAndCatchIO $ run $ findXeroOrder (oaddress o') @@ -850,12 +851,12 @@ routes pipe config = do ]) -- Get the xeroaccount code get "/api/xeroaccount" $ do - session <- queryParam "session" - user <- liftIO $ run (findUser session) + session <- param "session" + user <- liftAndCatchIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status unauthorized401 Just u -> do - res <- liftIO $ run (findToken $ uaddress u) + res <- liftAndCatchIO $ run (findToken $ uaddress u) let c = cast' . Doc =<< res case c of Nothing -> status noContent204 @@ -868,27 +869,27 @@ routes pipe config = do ]) -- Save the xeroaccount code post "/api/xeroaccount" $ do - session <- queryParam "session" - c <- queryParam "code" - user <- liftIO $ run (findUser session) + 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 - liftIO $ run (addAccCode oAdd c) + liftAndCatchIO $ run (addAccCode oAdd c) status accepted202 -- Get the WooCommerce token get "/api/wootoken" $ do - session <- queryParam "session" - user <- liftIO $ run (findUser session) + session <- param "session" + user <- liftAndCatchIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status unauthorized401 Just u -> do - owner <- liftIO $ run (findOwner $ uaddress u) + owner <- liftAndCatchIO $ run (findOwner $ uaddress u) case cast' . Doc =<< owner of Nothing -> status internalServerError500 Just o -> do - res <- liftIO $ run (findWooToken $ o_id o) + res <- liftAndCatchIO $ run (findWooToken $ o_id o) let t1 = cast' . Doc =<< res case t1 of Nothing -> status noContent204 @@ -901,28 +902,28 @@ routes pipe config = do , "siteurl" .= w_url t ]) post "/api/wootoken" $ do - oid <- queryParam "ownerid" - session <- queryParam "session" - user <- liftIO $ run (findUser session) + oid <- param "ownerid" + session <- param "session" + user <- liftAndCatchIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status unauthorized401 Just u -> do - res <- liftIO $ run (findOwnerById oid) + res <- liftAndCatchIO $ run (findOwnerById oid) case cast' . Doc =<< res of Nothing -> status badRequest400 Just o -> do if oaddress o == uaddress u then do tk <- liftIO generateToken - liftIO $ run (generateWooToken o tk) + liftAndCatchIO $ run (generateWooToken o tk) status accepted202 else status forbidden403 -- Authenticate the WooCommerce plugin get "/auth" $ do - oid <- queryParam "ownerid" - t <- queryParam "token" - siteurl <- queryParam "siteurl" - res <- liftIO $ run (findWooToken $ Just (read oid)) + oid <- param "ownerid" + t <- param "token" + siteurl <- param "siteurl" + res <- liftAndCatchIO $ run (findWooToken $ Just (read oid)) let c1 = cast' . Doc =<< res case c1 of Nothing -> do @@ -934,7 +935,7 @@ routes pipe config = do if blk3Hash t == blk3Hash (T.unpack $ w_token c) then if isNothing (w_url c) then do - liftIO $ run (addUrl c siteurl) + liftAndCatchIO $ run (addUrl c siteurl) status ok200 Web.Scotty.json (object @@ -972,20 +973,18 @@ routes pipe config = do where blk3Hash :: String -> String blk3Hash s = show - (BLK.hash - Nothing - [BA.pack . BS.unpack . C.pack $ s :: BA.Bytes] :: BLK.Digest + (BLK.hash [BA.pack . BS.unpack . C.pack $ s :: BA.Bytes] :: BLK.Digest BLK.DEFAULT_DIGEST_LEN) get "/woopayment" $ do - 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)) + 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)) let c = cast' . Doc =<< res case c of Nothing -> do @@ -997,7 +996,7 @@ routes pipe config = do (E.decodeUtf8With lenientDecode . B64.decodeLenient . C.pack) sUrl == fromMaybe "" (w_url x) then do - zecPriceDb <- liftIO (run (findPrice curr)) + zecPriceDb <- liftAndCatchIO (run (findPrice curr)) let zecPrice = parseZGoPrice =<< zecPriceDb case zecPrice of Nothing -> do @@ -1006,7 +1005,8 @@ routes pipe config = do (object ["message" .= ("Currency not supported" :: String)]) Just zP -> do ownerDb <- - liftIO $ run (findOwnerById (T.pack . show $ w_owner x)) + liftAndCatchIO $ + run (findOwnerById (T.pack . show $ w_owner x)) let owner = cast' . Doc =<< ownerDb case owner of Nothing -> do @@ -1047,7 +1047,7 @@ routes pipe config = do 0 0 0 - newId <- liftIO $ run (insertWooOrder newOrder) + newId <- liftAndCatchIO $ run (insertWooOrder newOrder) status ok200 Web.Scotty.json (object ["order" .= show newId, "token" .= tk]) @@ -1061,8 +1061,8 @@ routes pipe config = do Web.Scotty.json (object ["message" .= ("Incorrect plugin config" :: String)]) get "/checkuser" $ do - sess <- queryParam "session" - user <- liftIO $ run (findUser sess) + sess <- param "session" + user <- liftAndCatchIO $ run (findUser sess) case parseUserBson =<< user of Nothing -> status noContent204 Just u -> do @@ -1070,8 +1070,8 @@ routes pipe config = do Web.Scotty.json (object ["validated" .= uvalidated u]) --Get user associated with session get "/api/user" $ do - sess <- queryParam "session" - user <- liftIO $ run (findUser sess) + sess <- param "session" + user <- liftAndCatchIO $ run (findUser sess) case user of Nothing -> status noContent204 Just u -> do @@ -1083,20 +1083,19 @@ routes pipe config = do ]) --Validate user, updating record post "/validateuser" $ do - providedPin <- queryParam "pin" - sess <- queryParam "session" + providedPin <- param "pin" + sess <- param "session" let pinHash = BLK.hash - Nothing [ BA.pack . BS.unpack . C.pack . T.unpack $ providedPin <> sess :: BA.Bytes ] - user <- liftIO $ run (findUser sess) + user <- liftAndCatchIO $ 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 == @@ -1104,31 +1103,30 @@ routes pipe config = do (pinHash :: BLK.Digest BLK.DEFAULT_DIGEST_LEN)) if ans then do - liftIO $ run (validateUser sess) + liftAndCatchIO $ run (validateUser sess) status accepted202 - else status noContent204 `debug` - ("Pins didn't match: " ++ - T.unpack providedPin ++ " " ++ T.unpack (upin pUser)) + else status noContent204 --`debug` ("Pins didn't match: " ++ providedPin ++ " " ++ T.unpack (upin pUser)) --Delete user Web.Scotty.delete "/api/user/:id" $ do - userId <- captureParam "id" - session <- queryParam "session" + userId <- param "id" + session <- param "session" let r = mkRegex "^[a-f0-9]{24}$" if matchTest r userId then do - u <- liftIO $ run (findUserById userId) + u <- liftAndCatchIO $ run (findUserById userId) case cast' . Doc =<< u of Nothing -> status badRequest400 Just u' -> if session == usession u' then do - liftIO $ run (deleteUser userId) + liftAndCatchIO $ run (deleteUser userId) status ok200 else status forbidden403 else status badRequest400 --Get current blockheight from Zcash node get "/blockheight" $ do - blockInfo <- liftIO $ makeZcashCall nodeUser nodePwd "getblock" ["-1"] + blockInfo <- + liftAndCatchIO $ makeZcashCall nodeUser nodePwd "getblock" ["-1"] let content = getResponseBody blockInfo :: RpcResponse Block if isNothing (err content) then do @@ -1140,12 +1138,12 @@ routes pipe config = do get "/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress]) --Get owner by address get "/api/owner" $ do - session <- queryParam "session" - user <- liftIO $ run (findUser session) + session <- param "session" + user <- liftAndCatchIO $ run (findUser session) case parseUserBson =<< user of Nothing -> status noContent204 Just u -> do - owner <- liftIO $ run (findOwner $ uaddress u) + owner <- liftAndCatchIO $ run (findOwner $ uaddress u) case cast' . Doc =<< owner of Nothing -> status noContent204 Just o -> do @@ -1156,8 +1154,8 @@ routes pipe config = do , "owner" .= getOwnerSettings o ]) get "/ownerid" $ do - id <- queryParam "id" - owner <- liftIO $ run (findOwnerById id) + id <- param "id" + owner <- liftAndCatchIO $ run (findOwnerById id) case owner of Nothing -> status noContent204 Just o -> do @@ -1173,15 +1171,15 @@ routes pipe config = do ]) --Upsert owner to DB post "/api/owner" $ do - s <- queryParam "session" - u <- liftIO $ run (findUser s) + s <- param "session" + u <- liftAndCatchIO $ run (findUser s) o <- jsonData now <- liftIO getCurrentTime let q = payload (o :: Payload OwnerData) case parseUserBson =<< u of Nothing -> status internalServerError500 Just u' -> do - liftIO $ + liftAndCatchIO $ run $ upsertOwner $ Owner @@ -1213,8 +1211,8 @@ routes pipe config = do False status accepted202 post "/api/ownersettings" $ do - s <- queryParam "session" - u <- liftIO $ run (findUser s) + s <- param "session" + u <- liftAndCatchIO $ run (findUser s) o <- jsonData now <- liftIO getCurrentTime let q = payload (o :: Payload OwnerSettings) @@ -1223,12 +1221,12 @@ routes pipe config = do Just u' -> do if os_address q == uaddress u' then do - liftIO $ run $ updateOwnerSettings q + liftAndCatchIO $ run $ updateOwnerSettings q status accepted202 else status noContent204 post "/api/ownervk" $ do - s <- queryParam "session" - u <- liftIO $ run (findUser s) + s <- param "session" + u <- liftAndCatchIO $ run (findUser s) o <- jsonData let q = payload (o :: Payload String) let qRaw = decodeBech32 $ C.pack q @@ -1245,56 +1243,61 @@ routes pipe config = do qBytes (bytes . decodeBech32 . C.pack . T.unpack $ uaddress u') then do - owner <- liftIO $ run (findOwner $ uaddress u') + owner <- liftAndCatchIO $ run (findOwner $ uaddress u') case cast' . Doc =<< owner of Nothing -> status badRequest400 Just o' -> do unless (oviewkey o' /= "") $ do - liftIO $ run (upsertViewingKey o' q) + liftAndCatchIO $ run (upsertViewingKey o' q) status created201 else status forbidden403 else case decodeUfvk (C.pack q) of Nothing -> status badRequest400 Just fvk -> do - case isValidUnifiedAddress $ - C.pack . T.unpack $ uaddress u' of - Just uaok -> do + if isValidUnifiedAddress $ + C.pack . T.unpack $ uaddress u' + then do if matchOrchardAddress (C.pack q) (C.pack . T.unpack $ uaddress u') then do - owner <- liftIO $ run (findOwner $ uaddress u') + owner <- + liftAndCatchIO $ run (findOwner $ uaddress u') case cast' . Doc =<< owner of Nothing -> status badRequest400 Just o' -> do unless (oviewkey o' /= "") $ do - liftIO $ run (upsertViewingKey o' q) + liftAndCatchIO $ + run (upsertViewingKey o' q) status created201 else status forbidden403 - Nothing -> do + else do if matchSaplingAddress (s_key fvk) (bytes . decodeBech32 . C.pack . T.unpack $ uaddress u') then do - owner <- liftIO $ run (findOwner $ uaddress u') + owner <- + liftAndCatchIO $ run (findOwner $ uaddress u') case cast' . Doc =<< owner of Nothing -> status badRequest400 Just o' -> do unless (oviewkey o' /= "") $ do - liftIO $ run (upsertViewingKey o' q) + liftAndCatchIO $ + run (upsertViewingKey o' q) status created201 else status forbidden403 --Get items associated with the given address get "/api/items" $ do - session <- queryParam "session" - user <- liftIO $ run (findUser session) + session <- param "session" + user <- liftAndCatchIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status forbidden403 Just u -> do - items <- liftIO $ run (findItems $ uaddress u) - if not (null items) - then do + items <- liftAndCatchIO $ run (findItems $ uaddress u) + case items of + [] -> status noContent204 + _ -> do let pItems = map (cast' . Doc) items :: [Maybe Item] status ok200 Web.Scotty.json @@ -1302,42 +1305,41 @@ routes pipe config = do [ "message" .= ("Items found!" :: String) , "items" .= toJSON pItems ]) - else status noContent204 --Upsert item post "/api/item" $ do i <- jsonData - session <- queryParam "session" - user <- liftIO $ run (findUser session) + 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 - _ <- liftIO $ run (upsertItem q) + _ <- liftAndCatchIO $ run (upsertItem q) status created201 else status forbidden403 --Delete item Web.Scotty.delete "/api/item/:id" $ do - session <- queryParam "session" - oId <- captureParam "id" - u' <- liftIO $ checkUser run session + session <- param "session" + oId <- param "id" + u' <- liftAndCatchIO $ checkUser run session case u' of Nothing -> status forbidden403 Just u -> do - i <- liftIO $ run (findItemById oId) + i <- liftAndCatchIO $ run (findItemById oId) case cast' . Doc =<< i of Nothing -> status badRequest400 Just i' -> do if iowner i' == uaddress u then do - liftIO $ run (deleteItem oId) + liftAndCatchIO $ run (deleteItem oId) status ok200 else status forbidden403 --Get price for Zcash get "/price" $ do - curr <- queryParam "currency" - pr <- liftIO $ run (findPrice curr) + curr <- param "currency" + pr <- liftAndCatchIO $ run (findPrice curr) case parseZGoPrice =<< pr of Nothing -> do status noContent204 @@ -1346,15 +1348,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 <- queryParam "session" - user <- liftIO $ run (findUser session) + session <- param "session" + user <- liftAndCatchIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status unauthorized401 Just u -> do - myOrders <- liftIO $ run (findAllOrders $ uaddress u) - if null myOrders - then status noContent204 - else do + myOrders <- liftAndCatchIO $ run (findAllOrders $ uaddress u) + case myOrders of + [] -> status noContent204 + _ -> do let pOrders = map (cast' . Doc) myOrders :: [Maybe ZGoOrder] status ok200 Web.Scotty.json @@ -1364,18 +1366,18 @@ routes pipe config = do ]) --Get order by id for receipts get "/order/:id" $ do - oId <- captureParam "id" - token <- queryParam "token" + oId <- param "id" + token <- param "token" let r = mkRegex "^[a-f0-9]{24}$" if matchTest r oId then do - myOrder <- liftIO $ run (findOrderById oId) + myOrder <- liftAndCatchIO $ run (findOrderById oId) case cast' . Doc =<< myOrder of Nothing -> status noContent204 Just pOrder -> do if qtoken pOrder == token then do - shop <- liftIO $ run (findOwner $ qaddress pOrder) + shop <- liftAndCatchIO $ run (findOwner $ qaddress pOrder) case cast' . Doc =<< shop of Nothing -> status badRequest400 Just s -> do @@ -1390,8 +1392,8 @@ routes pipe config = do else status badRequest400 --Get order by session get "/api/order" $ do - sess <- queryParam "session" - myOrder <- liftIO $ run (findOrder sess) + sess <- param "session" + myOrder <- liftAndCatchIO $ run (findOrder sess) case myOrder of Nothing -> status noContent204 Just o -> do @@ -1411,7 +1413,7 @@ routes pipe config = do {-let q = payload (newOrder :: Payload ZGoOrder)-} {-_ <- liftIO $ run (upsertXeroOrder q)-} {-myOrder <--} - {-liftIO $-} + {-liftAndCatchIO $-} {-run (findXeroOrder (qaddress q) (qexternalInvoice q) (qshortCode q))-} {-case myOrder of-} {-Nothing -> status noContent204-} @@ -1430,12 +1432,12 @@ routes pipe config = do post "/api/order" $ do newOrder <- jsonData let q = payload (newOrder :: Payload ZGoOrder) - session <- queryParam "session" - user <- liftIO $ run (findUser session) + session <- param "session" + user <- liftAndCatchIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status unauthorized401 Just u -> do - owner <- liftIO $ run $ findOwner (uaddress u) + owner <- liftAndCatchIO $ run $ findOwner (uaddress u) case cast' . Doc =<< owner of Nothing -> status badRequest400 Just o -> do @@ -1447,7 +1449,8 @@ routes pipe config = do if ovat o then ovatValue o else 0 - dbOrder <- liftIO $ run (findOrderById $ maybe "0" show (q_id q)) + dbOrder <- + liftAndCatchIO $ run (findOrderById $ maybe "0" show (q_id q)) case cast' . Doc =<< dbOrder of Nothing -> do if uaddress u == qaddress q @@ -1456,7 +1459,7 @@ routes pipe config = do then do t <- liftIO generateToken _ <- - liftIO $ + liftAndCatchIO $ run (upsertOrder (setOrderToken (T.pack t) q) @@ -1465,7 +1468,7 @@ routes pipe config = do status created201 else do _ <- - liftIO $ + liftAndCatchIO $ access pipe master @@ -1482,7 +1485,7 @@ routes pipe config = do then do t <- liftIO generateToken _ <- - liftIO $ + liftAndCatchIO $ run (upsertOrder (setOrderToken (T.pack t) q) @@ -1491,7 +1494,7 @@ routes pipe config = do status created201 else do _ <- - liftIO $ + liftAndCatchIO $ access pipe master @@ -1502,62 +1505,62 @@ routes pipe config = do else status forbidden403 --Delete order Web.Scotty.delete "/api/order/:id" $ do - oId <- captureParam "id" - session <- queryParam "session" - o <- liftIO $ run (findOrderById oId) + 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 - liftIO $ run (deleteOrder oId) + liftAndCatchIO $ run (deleteOrder oId) status ok200 else status forbidden403 -- Get language for component get "/getmainlang" $ do - lang <- queryParam "lang" - txtPack' <- liftIO $ run (findLangComponent lang "main") + lang <- param "lang" + txtPack' <- liftAndCatchIO $ 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 <- queryParam "lang" - txtPack' <- liftIO $ run (findLangComponent lang "scan") + lang <- param "lang" + txtPack' <- liftAndCatchIO $ 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 <- queryParam "lang" - txtPack' <- liftIO $ run (findLangComponent lang "login") + lang <- param "lang" + txtPack' <- liftAndCatchIO $ 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 <- queryParam "lang" - txtPack' <- liftIO $ run (findLangComponent lang "invoice") + 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 <- queryParam "lang" - txtPack' <- liftIO $ run (findLangComponent lang "pmtservice") + 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 <- queryParam "component" - lang <- queryParam "lang" - txtPack' <- liftIO $ run (findLangComponent lang component) + component <- param "component" + lang <- param "lang" + txtPack' <- liftAndCatchIO $ run (findLangComponent lang component) let txtPack = cast' . Doc =<< txtPack' case txtPack of Nothing -> status noContent204 @@ -1567,7 +1570,7 @@ routes pipe config = do {-post "/api/setlang" $ do-} {-langComp <- jsonData-} {-_ <--} - {-liftIO $-} + {-liftAndCatchIO $-} {-mapM (run . loadLangComponent) (langComp :: [LangComponent])-} {-status created201-} {-(MonadIO m, FromJSON a)-} @@ -2005,17 +2008,17 @@ scanTxNative config pipe = do filterTx t = not (null (maybe [] rt_shieldedOutputs t)) || not (null (maybe [] rt_orchardActions t)) - extractTxs :: Maybe BlockResponse -> [HexString] + extractTxs :: Maybe BlockResponse -> [T.Text] extractTxs = maybe [] bl_txs getTxData :: - BS.ByteString -> BS.ByteString -> HexString -> IO (Maybe RawTxResponse) + BS.ByteString -> BS.ByteString -> T.Text -> IO (Maybe RawTxResponse) getTxData nodeUser nodePwd txid = do txInfo <- makeZcashCall nodeUser nodePwd "getrawtransaction" - [Data.Aeson.String (toText txid), Number $ SC.scientific 1 0] + [Data.Aeson.String txid, Number $ SC.scientific 1 0] let content = getResponseBody txInfo :: RpcResponse RawTxResponse if isNothing (err content) then return $ result content @@ -2073,7 +2076,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 . toText . ztxid $ x) (zmemo x) + let zM = runParser pZGoMemo (T.unpack . ztxid $ x) (zmemo x) case zM of Right m -> do case m_orderId m of @@ -2163,14 +2166,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 (map fromText txs)) + Just (BlockResponse c h t txs) cast' _ = Nothing val (BlockResponse c h t txs) = Doc [ "confirmations" =: c , "height" =: h , "time" =: t - , "tx" =: (map toText txs) + , "tx" =: txs , "network" =: ("mainnet" :: String) ] diff --git a/src/ZGoTx.hs b/src/ZGoTx.hs index f33d196..3749eb4 100644 --- a/src/ZGoTx.hs +++ b/src/ZGoTx.hs @@ -144,9 +144,9 @@ pUnifiedAddress :: Parser MemoToken pUnifiedAddress = do string "u1" a <- some alphaNumChar - case isValidUnifiedAddress (E.encodeUtf8 $ "u1" <> T.pack a) of - Just u -> pure $ Address $ T.pack ("u1" <> a) - Nothing -> fail "Failed to parse Unified Address" + if isValidUnifiedAddress (E.encodeUtf8 $ "u1" <> T.pack a) + then pure $ Address $ T.pack ("u1" <> a) + else fail "Failed to parse Unified Address" pOrderId :: Parser MemoToken pOrderId = do diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..8f78da2 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,84 @@ +# 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.17 + #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/zcash-haskell.git + commit: 1d558fc646a7758d60a721124812070de222c2e1 + - 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 diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000..d88e25b --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,109 @@ +# 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://github.com/reach-sh/haskell-hexstring.git + name: hexstring + pantry-tree: + sha256: 9ecf67856f59dfb382b283eceb42e4fc1865935d1a7e59111556ed381c6a2ffd + size: 687 + version: 0.11.1 + original: + commit: 085c16fb21b9f856a435a3faab980e7e0b319341 + git: https://github.com/reach-sh/haskell-hexstring.git +- completed: + commit: 1d558fc646a7758d60a721124812070de222c2e1 + git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git + name: zcash-haskell + pantry-tree: + sha256: eab3c6817bb3cb5738725824d16eb023cb2967ef3bbaa8f8252524602f606dbb + size: 1229 + version: 0.2.0 + original: + commit: 1d558fc646a7758d60a721124812070de222c2e1 + 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: 85d2382958c178491d3fe50d770a624621f5ab456beef7d31ac7521f780c9bc7 + size: 640042 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/17.yaml + original: lts-21.17 diff --git a/test/Spec.hs b/test/Spec.hs index c8fa585..35d60cf 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -28,7 +28,6 @@ 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 @@ -37,7 +36,7 @@ import Test.QuickCheck.Gen import Test.QuickCheck.Monadic import Text.Megaparsec import User -import Web.Scotty hiding (getResponseStatus) +import Web.Scotty import WooCommerce import Xero import ZGoBackend @@ -170,7 +169,7 @@ main = do res <- httpLBS req getResponseStatus res `shouldBe` unauthorized401 describe "blockheight endpoint" $ do - xit "returns a block number" $ do + it "returns a block number" $ do req <- testGet "/blockheight" @@ -777,10 +776,10 @@ main = do describe "Database actions" $ do describe "authentication" $ do it "should succeed with good creds" $ \p -> do - r <- liftIO $ access p master "test" (auth "zgo" "zcashrules") + r <- liftIO $ access p master "zgo" (auth "zgo" "zcashrules") r `shouldBe` True it "should fail with bad creds" $ \p -> do - r <- liftIO $ access p master "test" (auth "user" "pwd") + r <- liftIO $ access p master "zgo" (auth "user" "pwd") r `shouldBe` False describe "ZGo Pro sessions" $ do it "find in DB" $ \p -> do @@ -794,21 +793,21 @@ main = do it "should update" $ \p -> do doc <- access p master "test" $ findPrice "usd" case doc of - Nothing -> assertFailure "couldn't find price" + Nothing -> True `shouldBe` False Just d -> do let q = parseZGoPrice d case q of - Nothing -> assertFailure "couldn't parse price" + Nothing -> True `shouldBe` False Just r -> do let t1 = ZGoBackend.timestamp r _ <- checkZcashPrices p "test" doc2 <- access p master "test" $ findPrice "usd" case doc2 of - Nothing -> assertFailure "couldn't find price" + Nothing -> True `shouldBe` False Just d2 -> do let q2 = parseZGoPrice d2 case q2 of - Nothing -> assertFailure "couldn't parse price" + Nothing -> True `shouldBe` False Just r2 -> do let t2 = ZGoBackend.timestamp r2 t2 `shouldSatisfy` (t1 <) @@ -1134,7 +1133,7 @@ testItemAdd i = do openDbConnection :: IO Pipe openDbConnection = do pipe <- connect $ host "127.0.0.1" - access pipe master "test" (auth "zgo" "zcashrules") + access pipe master "zgo" (auth "zgo" "zcashrules") return pipe -- | Close the MongoDB pipe @@ -1157,7 +1156,7 @@ startAPI :: Config -> IO () startAPI config = do putStrLn "Starting test server ..." pipe <- connect $ host $ c_dbHost config - c <- access pipe master "test" (auth (c_dbUser config) (c_dbPassword config)) + c <- access pipe master "zgo" (auth (c_dbUser config) (c_dbPassword config)) let appRoutes = routes pipe config _ <- forkIO (scotty 3000 appRoutes) _ <- diff --git a/zcash-haskell b/zcash-haskell deleted file mode 160000 index 90c8a7c..0000000 --- a/zcash-haskell +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 90c8a7c3028bd6836dea5655221277a25d457653 diff --git a/zgo-backend.cabal b/zgo-backend.cabal index 416f405..0d59748 100644 --- a/zgo-backend.cabal +++ b/zgo-backend.cabal @@ -1,18 +1,18 @@ -cabal-version: 3.0 +cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack name: zgo-backend -version: 1.9.0 +version: 1.8.0 synopsis: Haskell Back-end for the ZGo point-of-sale application description: Please see the README at category: Web author: Rene Vergara maintainer: rene@vergara.network -copyright: 2022-2024 Vergara Technologies LLC -license: MIT +copyright: Copyright (c) 2023 Vergara Technologies LLC +license: BOSL license-file: LICENSE build-type: Simple extra-source-files: @@ -20,6 +20,10 @@ 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 @@ -33,6 +37,8 @@ library Xero ZGoBackend ZGoTx + other-modules: + Paths_zgo_backend hs-source-dirs: src build-depends: @@ -77,11 +83,13 @@ 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 @@ -90,7 +98,7 @@ executable zgo-backend-exe , http-conduit , http-types , megaparsec - , mongoDB >=2.7.1.4 + , mongoDB , scotty , securemem , text @@ -103,11 +111,13 @@ 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 @@ -121,11 +131,13 @@ 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 @@ -148,11 +160,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 @@ -163,7 +175,6 @@ test-suite zgo-backend-test , hspec-expectations-json , hspec-wai , http-conduit - , HUnit , http-types , megaparsec , mongoDB