zgo-backend/src/ZGoBackend.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}

module ZGoBackend where

import qualified BLAKE3 as BLK
import Config
import Control.Concurrent (forkIO, threadDelay)
import Control.Exception (try)
import Control.Monad
import Control.Monad.IO.Class
import Data.Aeson
import Data.Array
import qualified Data.Bson as B
import qualified Data.ByteArray as BA
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as C
import Data.Char
import qualified Data.HashMap.Strict as HM
import Data.HexString
import Data.Maybe
import qualified Data.Scientific as Scientific
import Data.SecureMem
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.Text.Lazy as L
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Time.Format
import Data.Typeable
import qualified Data.Vector as V
import Data.Vector.Internal.Check (doChecks)
import Data.Word
import Database.MongoDB
import Debug.Trace
import GHC.Generics
import Item
import LangComponent
import Network.HTTP.Simple
import Network.HTTP.Types.Status
import Network.Wai (Request, pathInfo)
import Network.Wai.Middleware.Cors
import Network.Wai.Middleware.HttpAuth
import Numeric
import Order
import Owner
import Payment
import System.IO.Unsafe
import System.Random
import Test.QuickCheck
import Test.QuickCheck.Instances
import Test.QuickCheck.Property (Result(ok))
import Text.Regex
import Text.Regex.Base
import User
import Web.Scotty
import WooCommerce
import Xero
import ZGoTx

-- Models for API objects
-- | A type to model Zcash RPC calls
data RpcCall =
  RpcCall
    { jsonrpc :: T.Text
    , callId :: T.Text
    , method :: T.Text
    , parameters :: [Data.Aeson.Value]
    }
  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 RpcError
    , respId :: T.Text
    , result :: Maybe r
    }
  deriving (Show, Generic, ToJSON)

instance (FromJSON r) => FromJSON (RpcResponse r) where
  parseJSON (Object obj) =
    MakeRpcResponse <$> obj .: "error" <*> obj .: "id" <*> obj .: "result"
  parseJSON _ = mzero

data RpcError =
  RpcError
    { ecode :: Double
    , emessage :: T.Text
    }
  deriving (Show, Generic, ToJSON)

instance FromJSON RpcError where
  parseJSON =
    withObject "RpcError" $ \obj -> do
      c <- obj .: "code"
      m <- obj .: "message"
      pure $ RpcError c m

data Payload r =
  Payload
    { payload :: r
    }
  deriving (Show, Generic, ToJSON)

instance (FromJSON r) => FromJSON (Payload r) where
  parseJSON (Object obj) = Payload <$> obj .: "payload"
  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
    { 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
  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
          (fromMaybe False c)
          conf
          (T.filter (/= '\NUL') $ 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
      ]

instance Arbitrary ZcashTx where
  arbitrary = do
    a <- arbitrary
    aZ <- arbitrary
    t <- arbitrary
    bh <- arbitrary
    bt <- arbitrary
    c <- arbitrary
    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]
    }
  deriving (Show, Generic)

instance FromJSON AddressGroup where
  parseJSON =
    withObject "AddressGroup" $ \obj -> do
      s <- obj .: "source"
      t <- obj .:? "transparent"
      sap <- obj .:? "sapling"
      uni <- obj .:? "unified"
      sL <- processSapling sap s
      tL <- processTransparent t s
      uL <- processUnified uni
      return $ AddressGroup s tL (concat sL) (concat uL)
    where
      processTransparent c s1 =
        case c of
          Nothing -> return []
          Just x -> do
            x' <- x .: "addresses"
            return $ map (ZcashAddress s1 [Transparent] Nothing) x'
      processSapling k s2 =
        case k of
          Nothing -> return []
          Just y -> mapM (processOneSapling s2) y
            where processOneSapling sx =
                    withObject "Sapling" $ \oS -> do
                      oS' <- oS .: "addresses"
                      return $ map (ZcashAddress sx [Sapling] Nothing) oS'
      processUnified u =
        case u of
          Nothing -> return []
          Just z -> mapM processOneAccount z
            where processOneAccount =
                    withObject "UAs" $ \uS -> do
                      acct <- uS .: "account"
                      uS' <- uS .: "addresses"
                      mapM (processUAs acct) uS'
                    where
                      processUAs a =
                        withObject "UAs" $ \v -> do
                          addr <- v .: "address"
                          p <- v .: "receiver_types"
                          return $ ZcashAddress MnemonicSeed p a addr

-- | Type for modelling the different address sources for Zcash 5.0.0
data AddressSource
  = LegacyRandom
  | Imported
  | ImportedWatchOnly
  | KeyPool
  | LegacySeed
  | MnemonicSeed
  deriving (Read, Show, Eq, Generic, ToJSON)

instance FromJSON AddressSource where
  parseJSON =
    withText "AddressSource" $ \case
      "legacy_random" -> return LegacyRandom
      "imported" -> return Imported
      "imported_watchonly" -> return ImportedWatchOnly
      "keypool" -> return KeyPool
      "legacy_hdseed" -> return LegacySeed
      "mnemonic_seed" -> return MnemonicSeed
      _ -> fail "Not a known address source"

data ZcashPool
  = Transparent
  | Sprout
  | Sapling
  | Orchard
  deriving (Show, Eq, Generic, ToJSON)

instance FromJSON ZcashPool where
  parseJSON =
    withText "ZcashPool" $ \case
      "p2pkh" -> return Transparent
      "sprout" -> return Sprout
      "sapling" -> return Sapling
      "orchard" -> return Orchard
      _ -> fail "Not a known Zcash pool"

data ZcashAddress =
  ZcashAddress
    { source :: AddressSource
    , pool :: [ZcashPool]
    , account :: Maybe Integer
    , addy :: T.Text
    }
  deriving (Eq)

instance Show ZcashAddress where
  show (ZcashAddress s p i a) =
    T.unpack (T.take 8 a) ++
    "..." ++ T.unpack (T.takeEnd 8 a) ++ " Pools: " ++ show p

-- | Helper function to turn a hex-encoded memo strings to readable text
decodeHexText :: String -> T.Text
decodeHexText h = E.decodeUtf8With lenientDecode $ BS.pack $ hexRead h
  where
    hexRead hexText
      | null chunk = []
      | otherwise =
        fromIntegral (read ("0x" <> chunk)) : hexRead (drop 2 hexText)
      where
        chunk = take 2 hexText

-- | Helper function to turn a string into a hex-encoded string
encodeHexText :: T.Text -> String
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
    }
  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

zToZGoTx :: ZcashTx -> ZGoTx
zToZGoTx (ZcashTx t a aZ bh bt c conf m) = do
  let r =
        mkRegex
          ".*ZGO::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12})\\sReply-To:\\s(zs[a-z0-9]{76}).*"
  let p =
        mkRegex
          ".*ZGOp::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12}).*"
  let y =
        mkRegex
          ".*MSG\\s(zs[a-z0-9]{76})\\s+ZGO::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12}).*"
  let reg = matchAllText r (T.unpack m)
  let reg2 = matchAllText p (T.unpack m)
  let reg3 = matchAllText y (T.unpack m)
  if not (null reg)
    then do
      let sess = T.pack (fst $ head reg ! 1)
      let nAddy = T.pack (fst $ head reg ! 2)
      ZGoTx Nothing nAddy sess conf bt a t m
    else do
      if not (null reg2)
        then do
          let sess = T.pack (fst $ head reg2 ! 1)
          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 t m
            else ZGoTx Nothing "" "" conf bt a t m

-- |Type to model a price in the ZGo database
data ZGoPrice =
  ZGoPrice
    { _id :: String
    , currency :: T.Text
    , price :: Double
    , timestamp :: UTCTime
    }
  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 t

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

sendPin ::
     BS.ByteString
  -> BS.ByteString
  -> T.Text
  -> T.Text
  -> T.Text
  -> Action IO String
sendPin nodeUser nodePwd nodeAddress addr pin = do
  let pd =
        [ Data.Aeson.String nodeAddress
        , Data.Aeson.Array
            (V.fromList
               [ object
                   [ "address" .= addr
                   , "amount" .= (0.00000001 :: Double)
                   , "memo" .= encodeHexText ("ZGo PIN: " <> pin)
                   ]
               ])
        ]
  r <- makeZcashCall nodeUser nodePwd "z_sendmany" pd
  let sCode = getResponseStatus (r :: Response Object)
  if sCode == ok200
    then return "Pin sent!"
    else return "Pin sending failed :("

-- | Function to create user from ZGoTx
addUser ::
     BS.ByteString
  -> BS.ByteString
  -> Pipe
  -> T.Text
  -> T.Text
  -> Maybe ZGoTx
  -> Action IO ()
addUser _ _ _ _ _ Nothing = return () --`debug` "addUser got Nothing"
addUser nodeUser nodePwd p db node (Just tx) = do
  isNew <- liftIO $ isUserNew p db tx
  when isNew $ do
    newPin <- liftIO generatePin
    _ <- sendPin nodeUser nodePwd node (address tx) (T.pack newPin)
    let pinHash =
          BLK.hash
            [ BA.pack . BS.unpack . C.pack . T.unpack $
              T.pack newPin <> session tx :: BA.Bytes
            ]
    insert_
      "users"
      [ "address" =: address tx
      , "session" =: session tx
      , "blocktime" =: blocktime tx
      , "pin" =:
        (T.pack . show $ (pinHash :: BLK.Digest BLK.DEFAULT_DIGEST_LEN))
      , "validated" =: False
      ]

-- | 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" =: (3 :: 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]

-- | Function to upsert ZGoTxs into the given collection
upsertZGoTx :: T.Text -> ZGoTx -> Action IO ()
upsertZGoTx coll t = do
  upsert (select ["txid" =: txid t] coll) (encodeZGoTxBson t)

-- | Function to upsert payment
upsertPayment :: Pipe -> T.Text -> ZGoTx -> IO ()
upsertPayment pipe dbName p = do
  zecData <- access pipe master dbName (findPrice "usd")
  let zecPrice = parseZGoPrice =<< zecData
  case zecPrice of
    Nothing -> error "Failed to fetch ZEC price"
    Just zp -> do
      let delta = sessionCalc (price zp) (amount p)
      let payTx =
            Payment
              Nothing
              delta
              False
              (address p)
              (session p)
              (blocktime p)
              (amount p)
              (txid p)
              (memo p)
      let payment = val payTx
      case payment of
        Doc d ->
          access pipe master dbName $
          upsert (select ["txid" =: txid p] "payments") d
        _ -> return ()

authSettings :: AuthSettings
authSettings = "ZGo Backend" {authIsProtected = needsAuth}

needsAuth :: Network.Wai.Request -> IO Bool
needsAuth req =
  return $
  case pathInfo req of
    "api":_ -> True
    _ -> False

-- | Main API routes
routes :: Pipe -> Config -> ScottyM ()
routes pipe config = do
  let run = access pipe master (c_dbName config)
  let passkey = c_passkey config
  let nodeUser = c_nodeUser config
  let nodePwd = c_nodePwd config
  let nodeAddress = c_nodeAddress config
  middleware $
    cors $
    const $
    Just
      simpleCorsResourcePolicy
        { corsRequestHeaders = ["Authorization", "Content-Type"]
        , corsMethods = "DELETE" : simpleMethods
        --, corsOrigins = Nothing
        }
  middleware $
    basicAuth
      (\u p -> return $ u == "user" && secureMemFromByteString p == passkey)
      authSettings
  --Get list of countries for UI
  get "/api/countries" $ 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)
             ])
  --Get Xero credentials
  get "/api/xero" $ do
    xeroConfig <- liftAndCatchIO $ run findXero
    case xeroConfig of
      Nothing -> status noContent204
      Just x -> do
        let xConfig = cast' (Doc x)
        case xConfig of
          Nothing -> status noContent204
          Just c -> do
            status ok200
            Web.Scotty.json
              (object
                 [ "message" .= ("Xero config found!" :: String)
                 , "xeroConfig" .= toJSON (c :: Xero)
                 ])
  get "/api/xerotoken" $ do
    code <- param "code"
    address <- param "address"
    xeroConfig <- liftAndCatchIO $ run findXero
    case xeroConfig of
      Nothing -> status noContent204
      Just x -> do
        let xConfig = cast' (Doc x)
        case xConfig of
          Nothing -> status noContent204
          Just c -> do
            res <-
              liftAndCatchIO $
              requestXeroToken pipe (c_dbName config) c code address
            if res
              then status ok200
              else status noContent204
  get "/api/invdata" $ do
    inv <- param "inv"
    oAddress <- param "address"
    xeroConfig <- liftAndCatchIO $ run findXero
    case xeroConfig of
      Nothing -> do
        status noContent204
        text "Xero App credentials not found"
      Just x -> do
        let xConfig = cast' (Doc x)
        case xConfig of
          Nothing -> do
            status noContent204
            text "Xero App credentials corrupted"
          Just c -> do
            res <-
              liftAndCatchIO $
              requestXeroToken pipe (c_dbName config) c "none" oAddress
            if res
              then do
                resInv <-
                  liftAndCatchIO $
                  getXeroInvoice pipe (c_dbName config) inv oAddress
                case resInv of
                  Nothing -> do
                    status noContent204
                    text "Xero invoice not found"
                  Just xI -> do
                    status ok200
                    Web.Scotty.json (object ["invdata" .= toJSON xI])
              else status noContent204
  -- Get the xeroaccount code
  get "/api/xeroaccount" $ do
    oAdd <- param "address"
    res <- liftAndCatchIO $ run (findToken oAdd)
    let c = cast' . Doc =<< res
    case c of
      Nothing -> status noContent204
      Just c1 -> do
        status ok200
        Web.Scotty.json
          (object
             [ "message" .= ("Xero account code found" :: String)
             , "code" .= t_code c1
             ])
  -- Save the xeroaccount code
  post "/api/xeroaccount" $ do
    oAdd <- param "address"
    c <- param "code"
    liftAndCatchIO $ run (addAccCode oAdd c)
    status accepted202
  -- Get the WooCommerce token
  get "/api/wootoken" $ do
    oid <- param "ownerid"
    res <- liftAndCatchIO $ run (findWooToken (read oid))
    let t1 = cast' . Doc =<< res
    case t1 of
      Nothing -> status noContent204
      Just t -> do
        status ok200
        Web.Scotty.json
          (object
             [ "ownerid" .= show (w_owner t)
             , "token" .= w_token t
             , "siteurl" .= w_url t
             ])
  post "/api/wootoken" $ do
    oid <- param "ownerid"
    res <- liftAndCatchIO $ run (findOwnerById oid)
    let o1 = cast' . Doc =<< res
    case o1 of
      Nothing -> status noContent204
      Just o -> do
        liftAndCatchIO $ run (generateWooToken o)
        status accepted202
  -- Authenticate the WooCommerce plugin
  get "/auth" $ do
    oid <- param "ownerid"
    t <- param "token"
    siteurl <- param "siteurl"
    res <- liftAndCatchIO $ run (findWooToken (read oid))
    let c1 = cast' . Doc =<< res
    case c1 of
      Nothing -> do
        status accepted202
        Web.Scotty.json
          (object
             ["authorized" .= False, "message" .= ("Owner not found" :: String)])
      Just c ->
        if t == w_token c
          then if isNothing (w_url c)
                 then do
                   liftAndCatchIO $ run (addUrl c siteurl)
                   status ok200
                   Web.Scotty.json
                     (object
                        [ "authorized" .= True
                        , "message" .= ("Authorized!" :: String)
                        ])
                 else do
                   if (E.decodeUtf8With lenientDecode .
                       B64.decodeLenient . C.pack . T.unpack)
                        siteurl ==
                      fromMaybe "" (w_url c)
                     then do
                       status ok200
                       Web.Scotty.json
                         (object
                            [ "authorized" .= True
                            , "message" .= ("Already authorized." :: String)
                            ])
                     else do
                       status accepted202
                       Web.Scotty.json
                         (object
                            [ "authorized" .= False
                            , "message" .=
                              ("ZGo shop already linked to " <>
                               fromMaybe "" (w_url c))
                            ])
          else do
            status accepted202
            Web.Scotty.json
              (object
                 [ "authorized" .= False
                 , "message" .= ("Token mismatch" :: String)
                 ])
  get "/woopayment" $ do
    oid <- param "ownerid"
    t <- param "token"
    ordId <- param "order_id"
    date <- param "date"
    curr <- param "currency"
    amount <- param "amount"
    sUrl <- param "siteurl"
    orderKey <- param "orderkey"
    res <- liftAndCatchIO $ run (findWooToken (read oid))
    let c = cast' . Doc =<< res
    case c of
      Nothing -> do
        status accepted202
        Web.Scotty.json
          (object ["message" .= ("Plugin not setup in ZGo" :: String)])
      Just x ->
        if t == w_token x &&
           (E.decodeUtf8With lenientDecode . B64.decodeLenient . C.pack) sUrl ==
           fromMaybe "" (w_url x)
          then do
            zecPriceDb <- liftAndCatchIO (run (findPrice curr))
            let zecPrice = parseZGoPrice =<< zecPriceDb
            case zecPrice of
              Nothing -> do
                status accepted202
                Web.Scotty.json
                  (object ["message" .= ("Currency not supported" :: String)])
              Just zP -> do
                ownerDb <-
                  liftAndCatchIO $
                  run (findOwnerById (T.pack . show $ w_owner x))
                let owner = cast' . Doc =<< ownerDb
                case owner of
                  Nothing -> do
                    status accepted202
                    Web.Scotty.json
                      (object ["message" .= ("Owner not found" :: String)])
                  Just o ->
                    if opaid o
                      then do
                        let newOrder =
                              ZGoOrder
                                Nothing
                                (oaddress o)
                                (case o_id o of
                                   Just o' -> "WC-" <> (T.pack . show $ o')
                                   Nothing -> "")
                                (parseTimeOrError
                                   True
                                   defaultTimeLocale
                                   "%Y-%0m-%0d"
                                   date)
                                True
                                (T.pack curr)
                                (price zP)
                                0.0
                                0.0
                                [ LineItem
                                    1.0
                                    (oname o <> " order " <> ordId)
                                    amount
                                ]
                                False
                                (T.concat
                                   [T.pack sUrl, "-", ordId, "-", orderKey])
                                ""
                        newId <- liftAndCatchIO $ run (insertWooOrder newOrder)
                        status ok200
                        Web.Scotty.json (object ["order" .= show newId])
                      else do
                        status accepted202
                        Web.Scotty.json
                          (object
                             ["message" .= ("ZGo shop not paid for" :: String)])
          else do
            status accepted202
            Web.Scotty.json
              (object ["message" .= ("Incorrect plugin config" :: String)])
  --Get user associated with session
  get "/api/user" $ do
    sess <- param "session"
    user <- liftAndCatchIO $ run (findUser sess)
    case user of
      Nothing -> status noContent204
      Just u ->
        Web.Scotty.json
          (object
             [ "message" .= ("User found" :: String)
             , "user" .= toJSON (parseUserBson u)
             ])
    --Validate user, updating record
  post "/api/validateuser" $ do
    providedPin <- param "pin"
    sess <- param "session"
    let pinHash =
          BLK.hash
            [ BA.pack . BS.unpack . C.pack . T.unpack $ providedPin <> sess :: BA.Bytes
            ]
    user <- liftAndCatchIO $ run (findUser sess)
    case user of
      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"
          Just pUser -> do
            let ans =
                  upin pUser ==
                  (T.pack . show $
                   (pinHash :: BLK.Digest BLK.DEFAULT_DIGEST_LEN))
            if ans
              then do
                liftAndCatchIO $ run (validateUser sess)
                status accepted202
              else status noContent204 --`debug` ("Pins didn't match: " ++ providedPin ++ " " ++ T.unpack (upin pUser))
    --Delete user
  Web.Scotty.delete "/api/user/:id" $ do
    userId <- param "id"
    let r = mkRegex "^[a-f0-9]{24}$"
    if matchTest r userId
      then do
        liftAndCatchIO $ run (deleteUser userId)
        status ok200
      else status noContent204
  --Get current blockheight from Zcash node
  get "/api/blockheight" $ do
    blockInfo <- makeZcashCall nodeUser nodePwd "getblock" ["-1"]
    let content = getResponseBody blockInfo :: RpcResponse Block
    if isNothing (err content)
      then do
        status ok200
        Web.Scotty.json $ fromMaybe (Block 0 0) (result content)
      else do
        status internalServerError500
  --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
    addr <- param "address"
    owner <- liftAndCatchIO $ run (findOwner addr)
    case owner of
      Nothing -> status noContent204
      Just o -> do
        let pOwner = cast' (Doc o)
        case pOwner of
          Nothing -> status internalServerError500
          Just q -> do
            status ok200
            Web.Scotty.json
              (object
                 [ "message" .= ("Owner found!" :: String)
                 , "owner" .= toJSON (q :: Owner)
                 ])
  get "/api/ownerid" $ do
    id <- param "id"
    owner <- liftAndCatchIO $ run (findOwnerById id)
    case owner of
      Nothing -> status noContent204
      Just o -> do
        let pOwner = cast' (Doc o)
        case pOwner of
          Nothing -> status internalServerError500
          Just q -> do
            status ok200
            Web.Scotty.json
              (object
                 [ "message" .= ("Owner found!" :: String)
                 , "owner" .= toJSON (q :: Owner)
                 ])
  --Upsert owner to DB
  post "/api/owner" $ do
    o <- jsonData
    let q = payload (o :: Payload Owner)
    if not (opayconf q)
      then do
        _ <- liftAndCatchIO $ run (upsertOwner q)
        status created201
      else do
        known <- liftAndCatchIO $ listAddresses nodeUser nodePwd
        if oaddress q `elem` map addy known
          then do
            _ <- liftAndCatchIO $ run (upsertOwner q)
            status created201
          else do
            vkInfo <-
              makeZcashCall
                nodeUser
                nodePwd
                "z_importviewingkey"
                [Data.Aeson.String (T.strip (oviewkey q)), "no"]
            let content = getResponseBody vkInfo :: RpcResponse Object
            if isNothing (err content)
              then do
                _ <- liftAndCatchIO $ run (upsertOwner q)
                status created201
              else do
                status internalServerError500
    --Get items associated with the given address
  get "/api/items" $ do
    addr <- param "address"
    items <- liftAndCatchIO $ run (findItems addr)
    case items of
      [] -> status noContent204
      _ -> do
        let pItems = map (cast' . Doc) items :: [Maybe Item]
        status ok200
        Web.Scotty.json
          (object
             ["message" .= ("Items found!" :: String), "items" .= toJSON pItems])
    --Upsert item
  post "/api/item" $ do
    i <- jsonData
    let q = payload (i :: Payload Item)
    _ <- liftAndCatchIO $ run (upsertItem q)
    status created201
    --Delete item
  Web.Scotty.delete "/api/item/:id" $ do
    oId <- param "id"
    let r = mkRegex "^[a-f0-9]{24}$"
    if matchTest r oId
      then do
        liftAndCatchIO $ run (deleteItem oId)
        status ok200
      else status noContent204
    --Get price for Zcash
  get "/api/price" $ do
    curr <- param "currency"
    pr <- liftAndCatchIO $ run (findPrice curr)
    case pr of
      Nothing -> do
        status noContent204
      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
    addr <- param "address"
    myOrders <- liftAndCatchIO $ run (findAllOrders addr)
    case myOrders of
      [] -> status noContent204
      _ -> do
        let pOrders = map (cast' . Doc) myOrders :: [Maybe ZGoOrder]
        status ok200
        Web.Scotty.json
          (object
             [ "message" .= ("Orders found!" :: String)
             , "orders" .= toJSON pOrders
             ])
    --Get order by id for receipts
  get "/api/order/:id" $ do
    oId <- param "id"
    let r = mkRegex "^[a-f0-9]{24}$"
    if matchTest r oId
      then do
        myOrder <- liftAndCatchIO $ run (findOrderById oId)
        case myOrder of
          Nothing -> status noContent204
          Just o -> do
            let o' = cast' (Doc o)
            case o' of
              Nothing -> status internalServerError500
              Just pOrder -> do
                status ok200
                Web.Scotty.json
                  (object
                     [ "message" .= ("Order found!" :: String)
                     , "order" .= toJSON (pOrder :: ZGoOrder)
                     ])
      else status noContent204
    --Get order by session
  get "/api/order" $ do
    sess <- param "session"
    myOrder <- liftAndCatchIO $ run (findOrder sess)
    case myOrder of
      Nothing -> status noContent204
      Just o -> do
        let o' = cast' (Doc o)
        case o' of
          Nothing -> status internalServerError500
          Just pOrder -> do
            status ok200
            Web.Scotty.json
              (object
                 [ "message" .= ("Order found!" :: String)
                 , "order" .= toJSON (pOrder :: ZGoOrder)
                 ])
  --Upsert xero order
  post "/api/orderx" $ do
    newOrder <- jsonData
    let q = payload (newOrder :: Payload ZGoOrder)
    _ <- liftIO $ run (upsertXeroOrder q)
    myOrder <-
      liftAndCatchIO $
      run (findXeroOrder (qaddress q) (qexternalInvoice q) (qshortCode q))
    case myOrder of
      Nothing -> status noContent204
      Just o -> do
        let o' = cast' (Doc o)
        case o' of
          Nothing -> status internalServerError500
          Just pOrder -> do
            status created201
            Web.Scotty.json
              (object
                 [ "message" .= ("Order found!" :: String)
                 , "order" .= toJSON (pOrder :: ZGoOrder)
                 ])
  -- Upsert order
  post "/api/order" $ do
    newOrder <- jsonData
    let q = payload (newOrder :: Payload ZGoOrder)
    _ <- liftAndCatchIO $ run (upsertOrder q)
    status created201
    --Delete order
  Web.Scotty.delete "/api/order/:id" $ do
    oId <- param "id"
    liftAndCatchIO $ run (deleteOrder oId)
    status ok200
  -- Get language for component
  get "/api/getlang" $ do
    component <- param "component"
    lang <- param "lang"
    txtPack' <- liftAndCatchIO $ run (findLangComponent lang component)
    let txtPack = cast' . Doc =<< txtPack'
    case txtPack of
      Nothing -> status noContent204
      Just tP -> do
        status ok200
        Web.Scotty.json $ toJSON (tP :: LangComponent)
  post "/api/setlang" $ do
    langComp <- jsonData
    _ <- liftAndCatchIO $ run (loadLangComponent langComp)
    status created201

-- | Make a Zcash RPC call
makeZcashCall ::
     (MonadIO m, FromJSON a)
  => BS.ByteString
  -> BS.ByteString
  -> T.Text
  -> [Data.Aeson.Value]
  -> m (Response a)
makeZcashCall username password m p = do
  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,nzd")
          ] $
        setRequestPort 443 $
        setRequestSecure True $
        setRequestHost "api.coingecko.com" $
        setRequestPath "/api/v3/simple/price" defaultRequest
  httpJSON priceRequest

-- | Function to update the Zcash prices in the ZGo db
checkZcashPrices :: Pipe -> T.Text -> IO ()
checkZcashPrices p db = do
  q <- try getZcashPrices
  case q of
    Left e -> print (e :: HttpException)
    Right q1 -> mapM_ (access p master db) (updatePrices (getResponseBody q1))

-- | Function to search for transactions for an address
listTxs ::
     BS.ByteString
  -> BS.ByteString
  -> T.Text
  -> Integer
  -> IO (Either T.Text [ZcashTx])
listTxs user pwd a confs = do
  res <-
    liftIO $
    makeZcashCall
      user
      pwd
      "z_listreceivedbyaddress"
      [Data.Aeson.String a, Data.Aeson.Number $ Scientific.scientific confs 0]
  let content = getResponseBody res :: RpcResponse [ZcashTx]
  case err content of
    Nothing ->
      return $ Right $ filter (not . zchange) $ fromMaybe [] $ result content
    Just e -> return $ Left $ "Error reading transactions: " <> emessage e

-- | Function to check the ZGo full node for new txs
scanZcash :: Config -> Pipe -> IO ()
scanZcash config pipe = do
  myTxs <-
    listTxs (c_nodeUser config) (c_nodePwd config) (c_nodeAddress config) 1
  case myTxs of
    Right txs -> do
      let r =
            mkRegex
              ".*ZGO::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12})\\sReply-To:\\s(zs[a-z0-9]{76}).*"
      let p =
            mkRegex
              ".*ZGOp::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12}).*"
      let y =
            mkRegex
              ".*MSG\\s(zs[a-z0-9]{76})\\s+ZGO::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12}).*"
      let k = map zToZGoTx (filter (isRelevant r) txs)
      mapM_ (access pipe master (c_dbName config) . upsertZGoTx "txs") k
      let j = map zToZGoTx (filter (isRelevant p) txs)
      mapM_ (upsertPayment pipe (c_dbName config)) j
      let l = map zToZGoTx (filter (isRelevant y) txs)
      mapM_ (access pipe master (c_dbName config) . upsertZGoTx "txs") l
    Left e -> do
      putStrLn $ "Error scanning node transactions: " ++ T.unpack e
      return ()

-- | Function to filter transactions
isRelevant :: Text.Regex.Regex -> ZcashTx -> Bool
isRelevant re t
  | zconfirmations t < 10 && (matchTest re . T.unpack . zmemo) t = True
  | otherwise = False

-- | Function to scan loaded viewing keys for payments
scanPayments :: Config -> Pipe -> IO ()
scanPayments config pipe = do
  shops <- listAddresses (c_nodeUser config) (c_nodePwd config)
  mapM_ (findPaidOrders config pipe) shops
  where
    findPaidOrders :: Config -> Pipe -> ZcashAddress -> IO ()
    findPaidOrders c p z = do
      paidTxs <- listTxs (c_nodeUser c) (c_nodePwd c) (addy z) 5
      case paidTxs of
        Right txs -> do
          let r = mkRegex ".*ZGo Order::([0-9a-fA-F]{24}).*"
          let k = filter (isRelevant r) txs
          let j = map (getOrderId r) k
          mapM_ (recordPayment p (c_dbName config)) j
          mapM_ (access p master (c_dbName config) . markOrderPaid) j
        Left e -> print e
    getOrderId :: Text.Regex.Regex -> ZcashTx -> (String, Double)
    getOrderId re t = do
      let reg = matchAllText re (T.unpack $ zmemo t)
      if not (null reg)
        then (fst $ head reg ! 1, zamount t)
        else ("", 0)
    recordPayment :: Pipe -> T.Text -> (String, Double) -> IO ()
    recordPayment p dbName x = do
      o <- access p master dbName $ findOrderById (fst x)
      let xOrder = o >>= (cast' . Doc)
      case xOrder of
        Nothing -> error "Failed to retrieve order from database"
        Just xO ->
          when
            (not (qpaid xO) &&
             qexternalInvoice xO /= "" && qtotalZec xO == snd x) $ do
            let sReg = mkRegex "(.*)-([a-fA-f0-9]{24})"
            let sResult = matchAllText sReg (T.unpack $ qsession xO)
            if not (null sResult)
              then case fst $ head sResult ! 1 of
                     "Xero" -> do
                       xeroConfig <- access p master dbName findXero
                       let xC = xeroConfig >>= (cast' . Doc)
                       case xC of
                         Nothing -> error "Failed to read Xero config"
                         Just xConf -> do
                           requestXeroToken p dbName xConf "" (qaddress xO)
                           payXeroInvoice
                             p
                             dbName
                             (qexternalInvoice xO)
                             (qaddress xO)
                             (qtotal xO)
                     "WC" -> do
                       let wOwner = fst $ head sResult ! 2
                       wooT <-
                         access p master dbName $ findWooToken (read wOwner)
                       let wT = wooT >>= (cast' . Doc)
                       case wT of
                         Nothing -> error "Failed to read WooCommerce token"
                         Just wt -> do
                           let iReg = mkRegex "(.*)-(.*)-.*"
                           let iResult =
                                 matchAllText
                                   iReg
                                   (T.unpack $ qexternalInvoice xO)
                           if not (null iResult)
                             then do
                               let wUrl =
                                     E.decodeUtf8With lenientDecode .
                                     B64.decodeLenient . C.pack $
                                     fst $ head iResult ! 1
                               let iNum = fst $ head iResult ! 2
                               payWooOrder
                                 (T.unpack wUrl)
                                 (C.pack iNum)
                                 (C.pack $ maybe "" show (q_id xO))
                                 (C.pack . T.unpack $ w_token wt)
                                 (C.pack . show $ qprice xO)
                                 (C.pack . show $ qtotalZec xO)
                             else error
                                    "Couldn't parse externalInvoice for WooCommerce"
                     _ -> putStrLn "Not an integration order"
              else putStrLn "Not an integration order"

-- | RPC methods
-- | List addresses with viewing keys loaded
listAddresses :: BS.ByteString -> BS.ByteString -> IO [ZcashAddress]
listAddresses user pwd = do
  response <- makeZcashCall user pwd "listaddresses" []
  let rpcResp = getResponseBody response
  case rpcResp of
    Nothing -> fail "Couldn't parse node response"
    Just res -> do
      let addys = fromMaybe [] $ result res :: [AddressGroup]
      let addList = concatMap getAddresses addys
      return $ filter (\a -> source a == ImportedWatchOnly) addList

-- | Helper function to extract addresses from AddressGroups
getAddresses :: AddressGroup -> [ZcashAddress]
getAddresses ag = agtransparent ag <> agsapling ag <> agunified ag

-- | Function to generate users from login txs
updateLogins :: Pipe -> Config -> IO ()
updateLogins pipe config = do
  let db = c_dbName config
  let nodeUser = c_nodeUser config
  let nodePwd = c_nodePwd config
  let addr = c_nodeAddress config
  results <-
    access
      pipe
      master
      db
      (rest =<<
       find (select ["confirmations" =: ["$lt" =: (100 :: Integer)]] "txs"))
  let parsed = map (cast' . Doc) results
  mapM_
    (access pipe master db . ZGoBackend.addUser nodeUser nodePwd pipe db addr)
    parsed

-- | Function to mark owners as paid
checkPayments :: Pipe -> T.Text -> IO ()
checkPayments pipe db = do
  qPayments <-
    access pipe master db (rest =<< find (select ["done" =: False] "payments"))
  let parsedPayments = map (cast' . Doc) qPayments
  mapM_ (payOwner pipe db) parsedPayments

payOwner :: Pipe -> T.Text -> Maybe Payment -> IO ()
payOwner p d x =
  case x of
    Nothing -> return ()
    Just k -> do
      now <- getCurrentTime
      if posixSecondsToUTCTime (fromInteger (pblocktime k + pdelta k)) <= now
        then markPaymentDone p d k
        else markOwnerPaid p d k
      where markPaymentDone :: Pipe -> T.Text -> Payment -> IO ()
            markPaymentDone pipe db pmt = do
              _ <-
                access
                  pipe
                  master
                  db
                  (modify
                     (select ["_id" =: p_id pmt] "payments")
                     ["$set" =: ["done" =: True]])
              return ()
            markOwnerPaid :: Pipe -> T.Text -> Payment -> IO ()
            markOwnerPaid pipe db pmt = do
              user <- access pipe master db (findUser $ psession pmt)
              let parsedUser = parseUserBson =<< user
              let zaddy = maybe "" uaddress parsedUser
              owner <- access pipe master db $ findOwner zaddy
              let foundOwner = (cast' . Doc) =<< owner
              case foundOwner of
                Nothing -> error "Couldn't find owner to mark as paid"
                Just fOwn -> do
                  if pdelta pmt > 90000000
                    then do
                      _ <-
                        access
                          pipe
                          master
                          db
                          (modify
                             (select ["_id" =: o_id fOwn] "owners")
                             [ "$set" =:
                               [ "paid" =: True
                               , "invoices" =: True
                               , "expiration" =:
                                 calculateExpiration
                                   fOwn
                                   (pdelta pmt - 90000000)
                                   (pblocktime pmt)
                               ]
                             ])
                      markPaymentDone pipe db pmt
                    else do
                      _ <-
                        access
                          pipe
                          master
                          db
                          (modify
                             (select ["_id" =: o_id fOwn] "owners")
                             [ "$set" =:
                               [ "paid" =: True
                               , "expiration" =:
                                 calculateExpiration
                                   fOwn
                                   (pdelta pmt)
                                   (pblocktime pmt)
                               ]
                             ])
                      markPaymentDone pipe db pmt
            calculateExpiration :: Owner -> Integer -> Integer -> UTCTime
            calculateExpiration o delta blocktime =
              if opaid o
                then addUTCTime
                       (secondsToNominalDiffTime (fromIntegral delta))
                       (oexpiration o)
                else posixSecondsToUTCTime (fromIntegral $ delta + blocktime)

expireOwners :: Pipe -> T.Text -> IO ()
expireOwners pipe db = do
  now <- getCurrentTime
  _ <-
    access
      pipe
      master
      db
      (modify
         (select ["expiration" =: ["$lt" =: now]] "owners")
         ["$set" =: ["paid" =: False]])
  return ()

debug = flip trace