Initial commit

.gitignore

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

ChangeLog.md

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

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

README.md

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

Setup.hs

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

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"

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

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]

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

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

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"

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