Vergara_Tech/zgo-backend
Vergara_Tech
/
zgo-backend
2
1
Fork 0
Code Issues Pull Requests Packages Projects Releases 4 Wiki Activity

Initial commit

This commit is contained in:
Rene Vergara 2022-04-22 11:15:23 -05:00
commit 5279f5c739
12 changed files with 685 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored Normal file
View File

@ -0,0 +1,2 @@
.stack-work/
*~

3
ChangeLog.md Normal file
View File

@ -0,0 +1,3 @@
# Changelog for zgo-backend
## Unreleased changes

23
LICENSE Normal file
View File

@ -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

1
README.md Normal file
View File

@ -0,0 +1 @@
# zgo-backend

2
Setup.hs Normal file
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

179
app/Main.hs Normal file
View File

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

68
package.yaml Normal file
View File

@ -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 <https://gitlab.com/pitmutt/zgo-backend#readme>
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

236
src/ZGoBackend.hs Normal file
View File

@ -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]

67
stack.yaml Normal file
View File

@ -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

13
stack.yaml.lock Normal file
View File

@ -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

14
test/Spec.hs Normal file
View File

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

77
zgo-backend.cabal Normal file
View File

@ -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 <https://gitlab.com/pitmutt/zgo-backend#readme>
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