From 5279f5c7394abfb22b8f96a217a1b05b5ea0c777 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Fri, 22 Apr 2022 11:15:23 -0500 Subject: [PATCH] Initial commit --- .gitignore | 2 + ChangeLog.md | 3 + LICENSE | 23 +++++ README.md | 1 + Setup.hs | 2 + app/Main.hs | 179 +++++++++++++++++++++++++++++++++++ package.yaml | 68 +++++++++++++ src/ZGoBackend.hs | 236 ++++++++++++++++++++++++++++++++++++++++++++++ stack.yaml | 67 +++++++++++++ stack.yaml.lock | 13 +++ test/Spec.hs | 14 +++ zgo-backend.cabal | 77 +++++++++++++++ 12 files changed, 685 insertions(+) create mode 100644 .gitignore create mode 100644 ChangeLog.md create mode 100644 LICENSE create mode 100644 README.md create mode 100644 Setup.hs create mode 100644 app/Main.hs create mode 100644 package.yaml create mode 100644 src/ZGoBackend.hs create mode 100644 stack.yaml create mode 100644 stack.yaml.lock create mode 100644 test/Spec.hs create mode 100644 zgo-backend.cabal diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..c368d45 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +.stack-work/ +*~ \ No newline at end of file diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 index 0000000..09271a5 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for zgo-backend + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..2caba40 --- /dev/null +++ b/LICENSE @@ -0,0 +1,23 @@ +[The MIT License (MIT)][] + +Copyright (c) 2022 Rene Vergara + +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: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +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. + +[The MIT License (MIT)]: https://opensource.org/licenses/MIT diff --git a/README.md b/README.md new file mode 100644 index 0000000..e958eb7 --- /dev/null +++ b/README.md @@ -0,0 +1 @@ +# zgo-backend diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..07353f4 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Concurrent (forkIO, threadDelay) +import Control.Monad +import Control.Monad.IO.Class +import Data.Aeson +import Data.SecureMem +import qualified Data.Text as T +import qualified Data.Text.Lazy as L +import Database.MongoDB +import GHC.Generics +import Network.HTTP.Simple +import Network.HTTP.Types.Status +import Network.Wai.Middleware.HttpAuth +import Web.Scotty +import ZGoBackend + +passkey :: SecureMem +passkey = secureMemFromByteString "superSecret" + +nodeAddress :: T.Text +nodeAddress = + "zs1xnpqd2tae9d95f8fhe4l0q7j44a5vf993m0pcnnvr56uqr4lgqlamesk5v4c5rhtvywc6lvlduy" + +dbUser :: T.Text +dbUser = "zgo" + +dbPassword :: T.Text +dbPassword = "zcashrules" + +main :: IO () +main = do + putStrLn "Starting Server..." + pipe <- connect $ host "127.0.0.1" + let run = access pipe master "zgo" + j <- run (auth dbUser dbPassword) + _ <- forkIO (setInterval 60 (checkZcashPrices pipe)) + if j + then putStrLn "Connected to MongoDB!" + else fail "MongoDB connection failed!" + scotty 4000 $ do + middleware $ + basicAuth + (\u p -> return $ u == "user" && secureMemFromByteString p == passkey) + "ZGo Backend" + --Get list of countries for UI + get "/api/countries" $ do + countries <- liftIO $ run listCountries + case countries of + [] -> do + status noContent204 + Web.Scotty.json + (object ["message" .= ("No countries available" :: String)]) + _ -> do + Web.Scotty.json + (object + [ "message" .= ("Country data found" :: String) + , "countries" .= toJSON (map parseCountryBson countries) + ]) + --Get user associated with session + get "/api/user" $ do + session <- param "session" + user <- liftIO $ run (findUser session) + case user of + Nothing -> status noContent204 + Just u -> + Web.Scotty.json + (object + [ "message" .= ("User found" :: String) + , "user" .= toJSON (parseUserBson u) + ]) + --Delete user + Web.Scotty.delete "/api/user/:id" $ do text "Deleted that guy!" + --Get txs from DB that have less than 10 confirmations + get "/api/pending" $ do + session <- param "session" + pending <- liftIO $ run (findPending session) + case pending of + [] -> do + status noContent204 + Web.Scotty.json + (object ["message" .= ("No pending transactions" :: String)]) + _ -> do + Web.Scotty.json + (object + [ "message" .= ("Found pending transactions" :: String) + , "txs" .= toJSON (map parseZGoTxBson pending) + ]) + --Get current blockheight from Zcash node + get "/api/blockheight" $ do + blockInfo <- makeZcashCall "getblock" ["-1"] + Web.Scotty.json (result (getResponseBody blockInfo :: RpcResponse Block)) + --Get transactions associated with ZGo node + get "/api/txs" $ do + txs <- makeZcashCall "z_listreceivedbyaddress" [nodeAddress] + Web.Scotty.json (result (getResponseBody txs :: RpcResponse [ZcashTx])) + --Get the ZGo node's shielded address + get "/api/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress]) + --Get owner by address + get "/api/owner" $ do text "Here's an owner for you" + --Upsert owner to DB + post "/api/owner" $ do text "I added an owner for you" + --Validate user, updating record + post "/api/validateuser" $ do text "Marked user as validated" + --Get items associated with the given address + get "/api/items" $ do text "Here are your items" + --Upsert item + post "/api/item" $ do text "I upserted the item for you" + --Delete item + Web.Scotty.delete "/api/item/:id" $ do text "Deleted that pesky item" + --Get price for Zcash + get "/api/price" $ do + currency <- param "currency" + price <- liftIO $ run (findPrice currency) + case price of + Nothing -> do + status noContent204 + Web.Scotty.json (object ["message" .= ("No price" :: String)]) + Just p -> do + Web.Scotty.json + (object + [ "message" .= ("Price found!" :: String) + , "price" .= toJSON (parseZGoPrice p) + ]) + --Get all closed orders for the address + get "/api/allorders" $ do text "Here are the orders" + --Get order by id for receipts + get "/api/order/:id" $ do + oId <- param "id" + text (L.pack ("Here's the order" <> oId)) + --Get order by session + get "/api/order" $ do + diff <- param "diff" + text (L.pack ("This is a diff order" <> diff)) + --Upsert order + post "/api/order" $ do text "Upserted your order" + get "/api/test" $ do + q <- liftIO getZcashPrices + a <- liftIO $ mapM_ run (updatePrices (getResponseBody q)) + text "Updated the DB!" + +-- |Make a Zcash RPC call +makeZcashCall :: (MonadIO m, FromJSON a) => T.Text -> [T.Text] -> m (Response a) +makeZcashCall m p = do + let username = "zecwallet" + let password = "rdsxlun6v4a" + let payload = + RpcCall {jsonrpc = "1.0", callId = "test", method = m, parameters = p} + let myRequest = + setRequestBodyJSON payload $ + setRequestPort 8232 $ + setRequestBasicAuth username password $ + setRequestMethod "POST" defaultRequest + httpJSON myRequest + +-- |Timer for repeating actions +setInterval :: Int -> IO () -> IO () +setInterval secs func = do + forever $ threadDelay (secs * 1000000) >> func + +-- |Function to query the CoinGecko API for the price of Zcash +getZcashPrices :: IO (Response CoinGeckoPrices) +getZcashPrices = do + let priceRequest = + setRequestQueryString + [("ids", Just "zcash"), ("vs_currencies", Just "usd,gbp,eur,cad,aud")] $ + setRequestPort 443 $ + setRequestSecure True $ + setRequestHost "api.coingecko.com" $ + setRequestPath "/api/v3/simple/price" defaultRequest + httpJSON priceRequest + +checkZcashPrices :: Pipe -> IO () +checkZcashPrices p = do + q <- getZcashPrices + mapM_ (access p master "zgo") (updatePrices (getResponseBody q)) + putStrLn "Got new prices" diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..1dd8650 --- /dev/null +++ b/package.yaml @@ -0,0 +1,68 @@ +name: zgo-backend +version: 0.1.0.0 +git: "https://gitlab.com/pitmutt/zgo-backend" +license: MIT +author: "Rene Vergara" +maintainer: "rene@vergara.network" +copyright: "Copyright (c) 2022 Vergara Technologies LLC" + +extra-source-files: +- README.md +- ChangeLog.md + +# 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 on GitLab at + +dependencies: +- base >= 4.7 && < 5 + +library: + source-dirs: src + dependencies: + - mongoDB + - time + - text + - unordered-containers + - bson + - aeson + +executables: + zgo-backend-exe: + main: Main.hs + source-dirs: app + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - zgo-backend + - base + - scotty + - wai-extra + - securemem + - text + - aeson + - mongoDB + - http-types + - http-conduit + - time + +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 diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs new file mode 100644 index 0000000..0a9dc9e --- /dev/null +++ b/src/ZGoBackend.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module ZGoBackend where + +import Control.Monad +import Control.Monad.IO.Class +import Data.Aeson +import qualified Data.Bson as B +import Data.Char +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import Data.Time.Clock +import Database.MongoDB +import GHC.Generics + +-- Models for API objects +-- | A type to model Zcash RPC calls +data RpcCall = + RpcCall + { jsonrpc :: T.Text + , callId :: T.Text + , method :: T.Text + , parameters :: [T.Text] + } + deriving (Show, Generic) + +instance ToJSON RpcCall where + toJSON (RpcCall j c m p) = + object ["jsonrpc" .= j, "id" .= c, "method" .= m, "params" .= p] + +-- | A type to model the response of the Zcash RPC +data RpcResponse r = + MakeRpcResponse + { err :: Maybe T.Text + , respId :: T.Text + , result :: r + } + deriving (Show, Generic, ToJSON) + +instance (FromJSON r) => FromJSON (RpcResponse r) where + parseJSON (Object obj) = + MakeRpcResponse <$> obj .: "error" <*> obj .: "id" <*> obj .: "result" + parseJSON _ = mzero + +-- | Type to model a (simplified) block of Zcash blockchain +data Block = + Block + { height :: Integer + , size :: Integer + } + deriving (Show, Generic, ToJSON) + +instance FromJSON Block where + parseJSON (Object obj) = Block <$> obj .: "height" <*> obj .: "size" + parseJSON _ = mzero + +-- | Type to model a Zcash shielded transaction +data ZcashTx = + ZcashTx + { txid :: T.Text + , amount :: Double + , amountZat :: Integer + , blockheight :: Integer + , blocktime :: Integer + , change :: Bool + , confirmations :: Integer + , memo :: String + } + deriving (Show, Generic) + +instance FromJSON ZcashTx where + parseJSON = + withObject "ZcashTx" $ \obj -> do + t <- obj .: "txid" + a <- obj .: "amount" + aZ <- obj .: "amountZat" + bh <- obj .: "blockheight" + bt <- obj .: "blocktime" + c <- obj .: "change" + conf <- obj .: "confirmations" + m <- obj .: "memo" + pure $ ZcashTx t a aZ bh bt c conf (decodeHexText m) + +instance ToJSON ZcashTx where + toJSON (ZcashTx t a aZ bh bt c conf m) = + object + [ "amount" .= a + , "amountZat" .= aZ + , "txid" .= t + , "blockheight" .= bh + , "blocktime" .= bt + , "change" .= c + , "confirmations" .= conf + , "memo" .= m + ] + +-- | Helper function to turn a hex-encoded memo strings to readable text +decodeHexText :: String -> String +decodeHexText hexText + | chunk == "00" = decodeHexText (drop 2 hexText) + | null chunk = "" + | otherwise = chr (read ("0x" <> chunk)) : decodeHexText (drop 2 hexText) + where + chunk = take 2 hexText + +-- 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 + } + deriving (Eq, Show, Generic, ToJSON) + +parseCountryBson :: B.Document -> Maybe Country +parseCountryBson d = do + i <- B.lookup "_id" d + n <- B.lookup "name" d + c <- B.lookup "code" d + pure $ Country (show (i :: B.ObjectId)) n c + +data User = + User + { _id :: String + , address :: T.Text + , session :: T.Text + , blocktime :: Integer + , pin :: T.Text + , validated :: Bool + , expired :: Bool + } + deriving (Eq, Show, Generic, ToJSON) + +parseUserBson :: B.Document -> Maybe User +parseUserBson d = do + i <- B.lookup "_id" d + a <- B.lookup "address" d + s <- B.lookup "session" d + b <- B.lookup "blocktime" d + p <- B.lookup "pin" d + v <- B.lookup "validated" d + e <- B.lookup "expired" d + pure $ User (show (i :: B.ObjectId)) a s b p v e + +-- | Type to model a ZGo transaction +data ZGoTx = + ZGoTx + { _id :: String + , address :: T.Text + , session :: T.Text + , confirmations :: Integer + , amount :: Double + , txid :: T.Text + , memo :: T.Text + } + deriving (Eq, Show, Generic, ToJSON) + +parseZGoTxBson :: B.Document -> Maybe ZGoTx +parseZGoTxBson d = do + i <- B.lookup "_id" d + a <- B.lookup "address" d + s <- B.lookup "session" d + c <- B.lookup "confirmations" d + am <- B.lookup "amount" d + t <- B.lookup "txid" d + m <- B.lookup "memo" d + pure $ ZGoTx (show (i :: B.ObjectId)) a s c am t m + +-- |Type to model a price in the ZGo database +data ZGoPrice = + ZGoPrice + { _id :: String + , currency :: T.Text + , price :: Double + , timestamp :: String + } + deriving (Eq, Show, Generic, ToJSON) + +parseZGoPrice :: B.Document -> Maybe ZGoPrice +parseZGoPrice d = do + i <- B.lookup "_id" d + c <- B.lookup "currency" d + p <- B.lookup "price" d + t <- B.lookup "timestamp" d + pure $ ZGoPrice (show (i :: B.ObjectId)) c p (show (t :: B.Value)) + +-- | Type for the CoinGecko response +newtype CoinGeckoPrices = + CoinGeckoPrices [(T.Text, Double)] + deriving (Eq, Show) + +instance FromJSON CoinGeckoPrices where + parseJSON = + withObject "CoinGeckoPrices" $ \obj -> do + z <- obj .: "zcash" + pure $ CoinGeckoPrices (HM.toList z) + +-- Functions for querying the ZGo database +-- | Function to query DB for countries list +listCountries :: Action IO [Document] +listCountries = rest =<< find (select [] "countries") + +-- | Function to query DB for unexpired user by session ID +findUser :: String -> Action IO (Maybe Document) +findUser s = findOne (select ["session" =: s, "expired" =: False] "users") + +-- | Function to query DB for transactions with less than 10 confirmations +findPending :: String -> Action IO [Document] +findPending s = + rest =<< + find + (select + ["session" =: s, "confirmations" =: ["$lt" =: (10 :: Integer)]] + "txs") + +-- | Function to query DB for price by currency +findPrice :: String -> Action IO (Maybe Document) +findPrice c = findOne (select ["currency" =: c] "prices") + +-- | Function to update prices in ZGo db +updatePrices :: CoinGeckoPrices -> [Action IO ()] +updatePrices (CoinGeckoPrices []) = [] +updatePrices (CoinGeckoPrices x) = do + updateOnePrice (head x) : updatePrices (CoinGeckoPrices (tail x)) + +-- | Function to update one price in ZGo db +updateOnePrice :: (T.Text, Double) -> Action IO () +updateOnePrice (c, v) = do + t <- liftIO getCurrentTime + upsert + (select ["currency" =: c] "prices") + ["currency" =: c, "price" =: v, "timestamp" =: t] diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..25fd3fd --- /dev/null +++ b/stack.yaml @@ -0,0 +1,67 @@ +# 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: + 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: [] + +# 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..cd82386 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,13 @@ +# 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: [] +snapshots: +- completed: + size: 618683 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/4.yaml + sha256: d4ee004c46ba878d2f304f5d748d493057be579192a8d148527f3ba55c9df57f + original: + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/4.yaml diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..35feb16 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,14 @@ +module Spec where + +import Test.Hspec +import Test.QuickCheck +import ZGoBackend + +main :: IO () +main = + hspec $ do + describe "Decode Memo" $ do + it "converts to readable text" $ do + decodeHexText + "5a474f3a3a35643364343439342d353163302d343332642d383439352d3035303431393935376165610a5265706c792d546f3a0a7a733177366e6b616d65617a633567756a6d363933353073796c35773874677679617068756d73337077386579747a7935796d303878376476736b6d796b6b61746d777275636d67763365723865" `shouldBe` + "ZGO::5d3d4494-51c0-432d-8495-050419957aea\nReply-To:\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" diff --git a/zgo-backend.cabal b/zgo-backend.cabal new file mode 100644 index 0000000..2892109 --- /dev/null +++ b/zgo-backend.cabal @@ -0,0 +1,77 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: zgo-backend +version: 0.1.0.0 +synopsis: Haskell Back-end for the ZGo point-of-sale application +description: Please see the README on GitLab at +category: Web +author: Rene Vergara +maintainer: rene@vergara.network +copyright: Copyright (c) 2022 Vergara Technologies LLC +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://gitlab.com/pitmutt/zgo-backend + +library + exposed-modules: + ZGoBackend + other-modules: + Paths_zgo_backend + hs-source-dirs: + src + build-depends: + aeson + , base >=4.7 && <5 + , bson + , mongoDB + , text + , time + , unordered-containers + default-language: Haskell2010 + +executable zgo-backend-exe + main-is: Main.hs + other-modules: + Paths_zgo_backend + hs-source-dirs: + app + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , base + , http-conduit + , http-types + , mongoDB + , scotty + , securemem + , text + , time + , wai-extra + , zgo-backend + default-language: Haskell2010 + +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 + build-depends: + QuickCheck + , base >=4.7 && <5 + , hspec + , zgo-backend + default-language: Haskell2010