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 Crypto.RNG (newCryptoRNGState, runCryptoRNGT)
import Crypto.RNG.Utils (randomString)
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 SC
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.UUID as U
import qualified Data.Vector as V
import Data.Word
import Database.MongoDB hiding (Order, lookup)
import Debug.Trace
import GHC.Generics
import Item
import LangComponent
import Network.HTTP.Simple
import Network.HTTP.Types.Status
import Network.Wai (Application, Middleware, Request(..), pathInfo, responseLBS)
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.Megaparsec (runParser)
import Text.Regex
import Text.Regex.Base
import User
import Web.Scotty
import WooCommerce
import Xero
import ZGoTx
import ZcashHaskell.Orchard
import ZcashHaskell.Sapling
import ZcashHaskell.Types
  ( BlockResponse(..)
  , RawData(..)
  , RawTxResponse(..)
  , RpcCall(..)
  , RpcError(..)
  , RpcResponse(..)
  , UnifiedFullViewingKey(..)
  )
import ZcashHaskell.Utils (decodeBech32, makeZcashCall)

-- Models for API objects
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

zToZGoTx' :: Config -> Pipe -> ZcashTx -> IO ()
zToZGoTx' config pipe (ZcashTx t a aZ bh bt c conf m) = do
  when (conf < c_confirmations config) $ do
    let zM = runParser pZGoMemo (T.unpack t) m
    case zM of
      Right zM' -> do
        print zM'
        let tx =
              ZGoTx
                Nothing
                (fromMaybe "" $ m_address zM')
                (maybe "" U.toText $ m_session zM')
                conf
                bt
                a
                t
                m
        if m_payment zM'
          then upsertPayment pipe (c_dbName config) tx
          else access pipe master (c_dbName config) $ upsertZGoTx "txs" tx
      Left e -> print $ "Failed to parse ZGo memo: " ++ show e

-- |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 <- liftIO $ try $ makeZcashCall nodeUser nodePwd "z_sendmany" pd --  IO (Either HttpException (Response Object))
  case r of
    Right res -> do
      let sCode = getResponseStatus (res :: Response Object)
      if sCode == ok200
        then return "Pin sent!"
        else return "Pin sending failed :("
    Left ex ->
      return $ "Failed to send tx to node :(" ++ show (ex :: HttpException)

-- | 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 -> do
          results <-
            access
              pipe
              master
              dbName
              (rest =<< find (select ["txid" =: txid p] "payments"))
          when (null results) $
            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

zgoAuth :: Pipe -> T.Text -> Middleware
zgoAuth pipe dbName app req respond = do
  let q = filter findSessionParam $ queryString req
  isFenced <- needsAuth req
  if isFenced
    then do
      if length q == 1
        then do
          isOk <- checkSession pipe dbName $ head q
          if isOk
            then app req respond
            else respond $
                 responseLBS unauthorized401 [] "ZGo API access denied!"
        else respond $ responseLBS unauthorized401 [] "ZGo API access denied!"
    else app req respond
  where
    findSessionParam :: QueryItem -> Bool
    findSessionParam (i, val) = i == "session"
    checkSession ::
         Pipe -> T.Text -> (BS.ByteString, Maybe BS.ByteString) -> IO Bool
    checkSession p db (k, v) =
      case v of
        Just sessionId ->
          isUserValid p db $ E.decodeUtf8With lenientDecode sessionId
        Nothing -> return 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
  middleware $ zgoAuth pipe $ c_dbName config
  --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"
    session <- param "session"
    user <- liftAndCatchIO $ run (findUser session)
    xeroConfig <- liftAndCatchIO $ run findXero
    case cast' . Doc =<< xeroConfig of
      Nothing -> status noContent204
      Just c -> do
        case cast' . Doc =<< user of
          Nothing -> status unauthorized401
          Just u -> do
            res <-
              liftAndCatchIO $
              requestXeroToken pipe (c_dbName config) c code $ uaddress u
            if res
              then status ok200
              else status noContent204
  post "/invdata" $ do
    invData <- jsonData
    xeroConfig <- liftAndCatchIO $ run findXero
    let invReq = payload (invData :: Payload XeroInvoiceRequest)
    case cast' . Doc =<< xeroConfig of
      Nothing -> do
        status ok200
        Web.Scotty.json
          (object
             [ "reportType" .= (1 :: Integer)
             , "order" .= (Nothing :: Maybe ZGoOrder)
             , "shop" .= (Nothing :: Maybe String)
             ])
      Just c -> do
        o <- liftAndCatchIO $ run $ findOwnerById $ xr_owner invReq
        case cast' . Doc =<< o of
          Nothing -> do
            status ok200
            Web.Scotty.json
              (object
                 [ "reportType" .= (2 :: Integer)
                 , "order" .= (Nothing :: Maybe ZGoOrder)
                 , "shop" .= (Nothing :: Maybe String)
                 ])
          Just o' -> do
            existingOrder <-
              liftAndCatchIO $
              run $
              findXeroOrder
                (oaddress o')
                (xr_invNo invReq)
                (xr_shortCode invReq)
            case cast' . Doc =<< existingOrder of
              Nothing -> do
                res <-
                  liftAndCatchIO $
                  requestXeroToken pipe (c_dbName config) c "none" $ oaddress o'
                if res
                  then do
                    resInv <-
                      liftAndCatchIO $
                      getXeroInvoice pipe (c_dbName config) (xr_invNo invReq) $
                      oaddress o'
                    case resInv of
                      Nothing -> do
                        status ok200
                        Web.Scotty.json
                          (object
                             [ "reportType" .= (2 :: Integer)
                             , "order" .= (Nothing :: Maybe ZGoOrder)
                             , "shop" .= (Nothing :: Maybe String)
                             ])
                      Just xI -> do
                        if xi_type xI == "ACCREC"
                          then if xi_status xI == "AUTHORISED"
                                 then if xi_currency xI ==
                                         T.toUpper (ocurrency o')
                                        then if xi_total xI == xr_amount invReq
                                               then do
                                                 now <- liftIO getCurrentTime
                                                 tk <- liftIO generateToken
                                                 pr <-
                                                   liftAndCatchIO $
                                                   run
                                                     (findPrice $
                                                      T.unpack . ocurrency $ o')
                                                 case parseZGoPrice =<< pr of
                                                   Nothing -> do
                                                     status ok200
                                                     Web.Scotty.json
                                                       (object
                                                          [ "reportType" .=
                                                            (7 :: Integer)
                                                          , "order" .=
                                                            (Nothing :: Maybe
                                                               ZGoOrder)
                                                          , "shop" .=
                                                            (Nothing :: Maybe
                                                               String)
                                                          ])
                                                   Just cp -> do
                                                     let newOrder =
                                                           ZGoOrder
                                                             Nothing
                                                             (oaddress o')
                                                             ("Xero-" <>
                                                              maybe
                                                                ""
                                                                (T.pack . show)
                                                                (o_id o'))
                                                             now
                                                             True
                                                             (ocurrency o')
                                                             (price cp)
                                                             (xi_total xI)
                                                             (xi_total xI /
                                                              price cp)
                                                             [ LineItem
                                                                 1
                                                                 ("Invoice from " <>
                                                                  oname o' <>
                                                                  " [" <>
                                                                  xi_number xI <>
                                                                  "]")
                                                                 (xi_total xI)
                                                             ]
                                                             False
                                                             (xi_number xI)
                                                             (xr_shortCode
                                                                invReq)
                                                             (T.pack tk)
                                                     _ <-
                                                       liftAndCatchIO $
                                                       run $
                                                       upsertOrder newOrder
                                                     finalOrder <-
                                                       liftAndCatchIO $
                                                       run $
                                                       findXeroOrder
                                                         (oaddress o')
                                                         (xi_number xI)
                                                         (xr_shortCode invReq)
                                                     case cast' . Doc =<<
                                                          finalOrder of
                                                       Nothing -> do
                                                         status
                                                           internalServerError500
                                                         text
                                                           "Unable to save order to DB"
                                                       Just fO -> do
                                                         status created201
                                                         Web.Scotty.json
                                                           (object
                                                              [ "reportType" .=
                                                                (0 :: Integer)
                                                              , "order" .=
                                                                toJSON
                                                                  (fO :: ZGoOrder)
                                                              , "shop" .=
                                                                oname o'
                                                              ])
                                               else do
                                                 status ok200
                                                 Web.Scotty.json
                                                   (object
                                                      [ "reportType" .=
                                                        (8 :: Integer)
                                                      , "order" .=
                                                        (Nothing :: Maybe
                                                           ZGoOrder)
                                                      , "shop" .=
                                                        (Nothing :: Maybe String)
                                                      ])
                                        else do
                                          status ok200
                                          Web.Scotty.json
                                            (object
                                               [ "reportType" .= (7 :: Integer)
                                               , "order" .=
                                                 (Nothing :: Maybe ZGoOrder)
                                               , "shop" .=
                                                 (Nothing :: Maybe String)
                                               ])
                                 else do
                                   status ok200
                                   Web.Scotty.json
                                     (object
                                        [ "reportType" .= (6 :: Integer)
                                        , "order" .= (Nothing :: Maybe ZGoOrder)
                                        , "shop" .= (Nothing :: Maybe String)
                                        ])
                          else do
                            status ok200
                            Web.Scotty.json
                              (object
                                 [ "reportType" .= (5 :: Integer)
                                 , "order" .= (Nothing :: Maybe ZGoOrder)
                                 , "shop" .= (Nothing :: Maybe String)
                                 ])
                  else do
                    status ok200
                    Web.Scotty.json
                      (object
                         [ "reportType" .= (1 :: Integer)
                         , "order" .= (Nothing :: Maybe ZGoOrder)
                         , "shop" .= (Nothing :: Maybe String)
                         ])
              Just eO -> do
                status created201
                Web.Scotty.json
                  (object
                     [ "reportType" .= (0 :: Integer)
                     , "order" .= toJSON (eO :: ZGoOrder)
                     , "shop" .= oname o'
                     ])
  -- Get the xeroaccount code
  get "/api/xeroaccount" $ do
    session <- param "session"
    user <- liftAndCatchIO $ run (findUser session)
    case cast' . Doc =<< user of
      Nothing -> status unauthorized401
      Just u -> do
        res <- liftAndCatchIO $ run (findToken $ uaddress u)
        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
    session <- param "session"
    c <- param "code"
    user <- liftAndCatchIO $ run (findUser session)
    case cast' . Doc =<< user of
      Nothing -> status unauthorized401
      Just u -> do
        let oAdd = uaddress u
        liftAndCatchIO $ run (addAccCode oAdd c)
        status accepted202
  -- Get the WooCommerce token
  get "/api/wootoken" $ do
    session <- param "session"
    user <- liftAndCatchIO $ run (findUser session)
    case cast' . Doc =<< user of
      Nothing -> status unauthorized401
      Just u -> do
        owner <- liftAndCatchIO $ run (findOwner $ uaddress u)
        case cast' . Doc =<< owner of
          Nothing -> status internalServerError500
          Just o -> do
            res <- liftAndCatchIO $ run (findWooToken $ o_id o)
            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"
    session <- param "session"
    user <- liftAndCatchIO $ run (findUser session)
    case cast' . Doc =<< user of
      Nothing -> status unauthorized401
      Just u -> do
        res <- liftAndCatchIO $ run (findOwnerById oid)
        case cast' . Doc =<< res of
          Nothing -> status badRequest400
          Just o -> do
            if oaddress o == uaddress u
              then do
                tk <- liftIO generateToken
                liftAndCatchIO $ run (generateWooToken o tk)
                status accepted202
              else status forbidden403
  -- Authenticate the WooCommerce plugin
  get "/auth" $ do
    oid <- param "ownerid"
    t <- param "token"
    siteurl <- param "siteurl"
    res <- liftAndCatchIO $ run (findWooToken $ Just (read oid))
    let c1 = cast' . Doc =<< res
    case c1 of
      Nothing -> do
        status accepted202
        Web.Scotty.json
          (object
             ["authorized" .= False, "message" .= ("Owner not found" :: String)])
      Just c ->
        if blk3Hash t == blk3Hash (T.unpack $ 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)
                 ])
        where blk3Hash :: String -> String
              blk3Hash s =
                show
                  (BLK.hash [BA.pack . BS.unpack . C.pack $ s :: BA.Bytes] :: BLK.Digest
                     BLK.DEFAULT_DIGEST_LEN)
  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 $ Just (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
                        tk <- liftIO generateToken
                        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])
                                ""
                                (T.pack tk)
                        newId <- liftAndCatchIO $ run (insertWooOrder newOrder)
                        status ok200
                        Web.Scotty.json
                          (object ["order" .= show newId, "token" .= tk])
                      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 "/checkuser" $ do
    sess <- param "session"
    user <- liftAndCatchIO $ run (findUser sess)
    case parseUserBson =<< user of
      Nothing -> status noContent204
      Just u -> do
        status ok200
        Web.Scotty.json (object ["validated" .= uvalidated u])
  --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 -> do
        status ok200
        Web.Scotty.json
          (object
             [ "message" .= ("User found" :: String)
             , "user" .= toJSON (parseUserBson u)
             ])
    --Validate user, updating record
  post "/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"
    session <- param "session"
    let r = mkRegex "^[a-f0-9]{24}$"
    if matchTest r userId
      then do
        u <- liftAndCatchIO $ run (findUserById userId)
        case cast' . Doc =<< u of
          Nothing -> status badRequest400
          Just u' ->
            if session == usession u'
              then do
                liftAndCatchIO $ run (deleteUser userId)
                status ok200
              else status forbidden403
      else status badRequest400
  --Get current blockheight from Zcash node
  get "/blockheight" $ do
    blockInfo <-
      liftAndCatchIO $ 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 "/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress])
  --Get owner by address
  get "/api/owner" $ do
    session <- param "session"
    user <- liftAndCatchIO $ run (findUser session)
    case parseUserBson =<< user of
      Nothing -> status noContent204
      Just u -> do
        owner <- liftAndCatchIO $ run (findOwner $ uaddress u)
        case cast' . Doc =<< owner of
          Nothing -> status noContent204
          Just o -> do
            status ok200
            Web.Scotty.json
              (object
                 [ "message" .= ("Owner found!" :: String)
                 , "owner" .= getOwnerSettings o
                 ])
  get "/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" .= getOwnerSettings q
                 ])
  --Upsert owner to DB
  post "/api/owner" $ do
    s <- param "session"
    u <- liftAndCatchIO $ run (findUser s)
    o <- jsonData
    now <- liftIO getCurrentTime
    let q = payload (o :: Payload OwnerData)
    case parseUserBson =<< u of
      Nothing -> status internalServerError500
      Just u' -> do
        liftAndCatchIO $
          run $
          upsertOwner $
          Owner
            Nothing
            (uaddress u')
            (od_name q)
            "usd"
            False
            0
            False
            0
            (od_first q)
            (od_last q)
            (od_email q)
            (od_street q)
            (od_city q)
            (od_state q)
            (od_postal q)
            (od_phone q)
            (od_website q)
            (od_country q)
            False
            False
            False
            now
            False
            ""
            ""
        status accepted202
  post "/api/ownersettings" $ do
    s <- param "session"
    u <- liftAndCatchIO $ run (findUser s)
    o <- jsonData
    now <- liftIO getCurrentTime
    let q = payload (o :: Payload OwnerSettings)
    case parseUserBson =<< u of
      Nothing -> status internalServerError500
      Just u' -> do
        if os_address q == uaddress u'
          then do
            liftAndCatchIO $ run $ updateOwnerSettings q
            status accepted202
          else status noContent204
  post "/api/ownervk" $ do
    s <- param "session"
    u <- liftAndCatchIO $ run (findUser s)
    o <- jsonData
    let q = payload (o :: Payload String)
    let qRaw = decodeBech32 $ C.pack q
    if hrp qRaw == "fail"
      then status badRequest400
      else do
        let qBytes = bytes qRaw
        case cast' . Doc =<< u of
          Nothing -> status unauthorized401
          Just u' -> do
            if isValidSaplingViewingKey qBytes
              then if matchSaplingAddress
                        qBytes
                        (bytes . decodeBech32 . C.pack . T.unpack $ uaddress u')
                     then do
                       owner <- liftAndCatchIO $ run (findOwner $ uaddress u')
                       case cast' . Doc =<< owner of
                         Nothing -> status badRequest400
                         Just o' -> do
                           unless (oviewkey o' /= "") $ do
                             vkInfo <-
                               liftAndCatchIO $
                               makeZcashCall
                                 nodeUser
                                 nodePwd
                                 "z_importviewingkey"
                                 [ Data.Aeson.String (T.strip . T.pack $ q)
                                 , "no"
                                 ] -- TODO: Remove this call to the node
                             let content =
                                   getResponseBody vkInfo :: RpcResponse Object
                             if isNothing (err content)
                               then do
                                 _ <-
                                   liftAndCatchIO $ run (upsertViewingKey o' q)
                                 status created201
                               else do
                                 text $ L.pack . show $ err content
                                 status badRequest400
                     else status forbidden403
              else status badRequest400 -- TODO: add Unified VK support
    --Get items associated with the given address
  get "/api/items" $ do
    session <- param "session"
    user <- liftAndCatchIO $ run (findUser session)
    case cast' . Doc =<< user of
      Nothing -> status forbidden403
      Just u -> do
        items <- liftAndCatchIO $ run (findItems $ uaddress u)
        case items of
          [] -> status noContent204
          _ -> do
            let pItems = map (cast' . Doc) items :: [Maybe Item]
            status ok200
            Web.Scotty.json
              (object
                 [ "message" .= ("Items found!" :: String)
                 , "items" .= toJSON pItems
                 ])
    --Upsert item
  post "/api/item" $ do
    i <- jsonData
    session <- param "session"
    user <- liftAndCatchIO $ run (findUser session)
    case cast' . Doc =<< user of
      Nothing -> status forbidden403
      Just u -> do
        let q = payload (i :: Payload Item)
        if uaddress u == iowner q
          then do
            _ <- liftAndCatchIO $ run (upsertItem q)
            status created201
          else status forbidden403
    --Delete item
  Web.Scotty.delete "/api/item/:id" $ do
    session <- param "session"
    oId <- param "id"
    u' <- liftAndCatchIO $ checkUser run session
    case u' of
      Nothing -> status forbidden403
      Just u -> do
        i <- liftAndCatchIO $ run (findItemById oId)
        case cast' . Doc =<< i of
          Nothing -> status badRequest400
          Just i' -> do
            if iowner i' == uaddress u
              then do
                liftAndCatchIO $ run (deleteItem oId)
                status ok200
              else status forbidden403
    --Get price for Zcash
  get "/price" $ do
    curr <- param "currency"
    pr <- liftAndCatchIO $ run (findPrice curr)
    case parseZGoPrice =<< pr of
      Nothing -> do
        status noContent204
      Just p -> do
        Web.Scotty.json
          (object ["message" .= ("Price found!" :: String), "price" .= toJSON p])
    --Get all closed orders for the address
  get "/api/allorders" $ do
    session <- param "session"
    user <- liftAndCatchIO $ run (findUser session)
    case cast' . Doc =<< user of
      Nothing -> status unauthorized401
      Just u -> do
        myOrders <- liftAndCatchIO $ run (findAllOrders $ uaddress u)
        case myOrders of
          [] -> status noContent204
          _ -> do
            let pOrders = map (cast' . Doc) myOrders :: [Maybe ZGoOrder]
            status ok200
            Web.Scotty.json
              (object
                 [ "message" .= ("Orders found!" :: String)
                 , "orders" .= toJSON pOrders
                 ])
    --Get order by id for receipts
  get "/order/:id" $ do
    oId <- param "id"
    token <- param "token"
    let r = mkRegex "^[a-f0-9]{24}$"
    if matchTest r oId
      then do
        myOrder <- liftAndCatchIO $ run (findOrderById oId)
        case cast' . Doc =<< myOrder of
          Nothing -> status noContent204
          Just pOrder -> do
            if qtoken pOrder == token
              then do
                shop <- liftAndCatchIO $ run (findOwner $ qaddress pOrder)
                case cast' . Doc =<< shop of
                  Nothing -> status badRequest400
                  Just s -> do
                    status ok200
                    Web.Scotty.json
                      (object
                         [ "message" .= ("Order found!" :: String)
                         , "order" .= toJSON (pOrder :: ZGoOrder)
                         , "shop" .= (oname s :: T.Text)
                         ])
              else status forbidden403
      else status badRequest400
    --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)
    session <- param "session"
    user <- liftAndCatchIO $ run (findUser session)
    case cast' . Doc =<< user of
      Nothing -> status unauthorized401
      Just u -> do
        if uaddress u == qaddress q
          then do
            if qtoken q == ""
              then do
                t <- liftIO generateToken
                _ <-
                  liftAndCatchIO $
                  run (upsertOrder $ setOrderToken (T.pack t) q)
                status created201
              else do
                _ <- liftAndCatchIO $ run (upsertOrder q)
                status created201
          else status forbidden403
    --Delete order
  Web.Scotty.delete "/api/order/:id" $ do
    oId <- param "id"
    session <- param "session"
    o <- liftAndCatchIO $ run (findOrderById oId)
    case cast' . Doc =<< o of
      Nothing -> status badRequest400
      Just order -> do
        if qsession order == session
          then do
            liftAndCatchIO $ run (deleteOrder oId)
            status ok200
          else status forbidden403
  -- Get language for component
  get "/getmainlang" $ do
    lang <- param "lang"
    txtPack' <- liftAndCatchIO $ run (findLangComponent lang "main")
    case cast' . Doc =<< txtPack' of
      Nothing -> status noContent204
      Just textPack -> do
        status ok200
        Web.Scotty.json $ toJSON (textPack :: LangComponent)
  get "/getscanlang" $ do
    lang <- param "lang"
    txtPack' <- liftAndCatchIO $ run (findLangComponent lang "scan")
    case cast' . Doc =<< txtPack' of
      Nothing -> status noContent204
      Just textPack -> do
        status ok200
        Web.Scotty.json $ toJSON (textPack :: LangComponent)
  get "/getloginlang" $ do
    lang <- param "lang"
    txtPack' <- liftAndCatchIO $ run (findLangComponent lang "login")
    case cast' . Doc =<< txtPack' of
      Nothing -> status noContent204
      Just textPack -> do
        status ok200
        Web.Scotty.json $ toJSON (textPack :: LangComponent)
  get "/getinvoicelang" $ do
    lang <- param "lang"
    txtPack' <- liftAndCatchIO $ run (findLangComponent lang "invoice")
    case cast' . Doc =<< txtPack' of
      Nothing -> status noContent204
      Just textPack -> do
        status ok200
        Web.Scotty.json $ toJSON (textPack :: LangComponent)
  get "/getpmtservicelang" $ do
    lang <- param "lang"
    txtPack' <- liftAndCatchIO $ run (findLangComponent lang "pmtservice")
    case cast' . Doc =<< txtPack' of
      Nothing -> status noContent204
      Just textPack -> do
        status ok200
        Web.Scotty.json $ toJSON (textPack :: LangComponent)
  get "/api/getlang" $ do
    component <- 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 $-}
      {-mapM (run . loadLangComponent) (langComp :: [LangComponent])-}
    {-status created201-}
     {-(MonadIO m, FromJSON a)-}
  {-=> BS.ByteString-}
  {--> BS.ByteString-}
  {--> T.Text-}
  {--> [Data.Aeson.Value]-}
  {--> m (Response a)-}
  {-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-}

-- | Make a Zcash RPC call
{-makeZcashCall ::-}
{-makeZcashCall username password m p = do-}
-- |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 <-
    try $
    makeZcashCall
      user
      pwd
      "z_listreceivedbyaddress"
      [Data.Aeson.String a, Data.Aeson.Number $ SC.scientific confs 0] :: IO
      (Either HttpException (Response (RpcResponse [ZcashTx])))
  case res of
    Right txList -> do
      let content = getResponseBody txList :: RpcResponse [ZcashTx]
      case err content of
        Nothing ->
          return $
          Right $ filter (not . zchange) $ fromMaybe [] $ result content
        Just e -> return $ Left $ "Error reading transactions: " <> emessage e
    Left ex -> return $ Left $ (T.pack . show) ex

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

-- | New function to scan transactions with parser
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 -> mapM_ (zToZGoTx' config pipe) txs
    Left e -> do
      putStrLn $ "Error scanning node transactions: " ++ T.unpack e

-- | Function to scan loaded viewing keys for payments
scanPayments :: Config -> Pipe -> IO ()
scanPayments config pipe = do
  shopRecords <- access pipe master (c_dbName config) findActiveOwners
  case shopRecords of
    [] -> return ()
    _ -> do
      let shops = cast' . Doc <$> shopRecords :: [Maybe Owner]
      let validShopAddresses = map (maybe "" oaddress) $ filter isJust shops
      mapM_ (findPaidOrders config pipe) validShopAddresses
      where findPaidOrders :: Config -> Pipe -> T.Text -> IO ()
            findPaidOrders c p z = do
              print z
              paidTxs <- listTxs (c_nodeUser c) (c_nodePwd c) z 5
              case paidTxs of
                Right txs -> do
                  let r = mkRegex ".*ZGo Order::([0-9a-fA-F]{24}).*"
                  let k = filter (isRelevant (c_confirmations c) r) txs
                  print k
                  let j = map (getOrderId r) k
                  mapM_ (recordPayment p (c_dbName config) z) 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 -> T.Text -> (String, Double) -> IO ()
            recordPayment p dbName z x = do
              print x
              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) && qtotalZec xO == snd x && z == qaddress xO) $ 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)
                                     (qtotalZec xO)
                                   liftIO $
                                     access p master dbName $ markOrderPaid x
                             "WC" -> do
                               let wOwner = fst $ head sResult ! 2
                               wooT <-
                                 access p master dbName $
                                 findWooToken $ Just (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)
                                       liftIO $
                                         access p master dbName $
                                         markOrderPaid x
                                     else error
                                            "Couldn't parse externalInvoice for WooCommerce"
                             _ -> putStrLn "Not an integration order"
                      else liftIO $ access p master dbName $ markOrderPaid x

-- | RPC methods
-- | List addresses with viewing keys loaded
listAddresses :: BS.ByteString -> BS.ByteString -> IO [ZcashAddress]
listAddresses user pwd = do
  response <-
    try $ makeZcashCall user pwd "listaddresses" [] :: IO
      (Either HttpException (Response (RpcResponse [AddressGroup])))
  case response of
    Right addrList -> do
      let rpcResp = getResponseBody addrList
      let addys = fromMaybe [] $ result rpcResp :: [AddressGroup]
      let addList = concatMap getAddresses addys
      return $ filter (\a -> source a == ImportedWatchOnly) addList
    Left ex -> fail $ show ex

-- | 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)
              -- print 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)
                               ]
                             ])
                      let proS =
                            ZGoProSession
                              Nothing
                              (oaddress fOwn)
                              (calculateExpiration
                                 fOwn
                                 (pdelta pmt - 90000000)
                                 (pblocktime pmt))
                              False
                      access pipe master db $ upsertProSession proS
                      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 ()

expireProSessions :: Pipe -> T.Text -> IO ()
expireProSessions pipe db = do
  now <- getCurrentTime
  psessions <- access pipe master db $ findExpiringProSessions now
  print $ length psessions
  let pSessObj = cast' . Doc <$> psessions
  mapM_ (sendExpiration pipe db) pSessObj
  where
    sendExpiration :: Pipe -> T.Text -> Maybe ZGoProSession -> IO ()
    sendExpiration pipe db zps =
      case zps of
        Nothing -> return ()
        Just z -> do
          access pipe master db $ removePro (psaddress z)
          access pipe master db $ closeProSession z

checkUser ::
     (Action IO (Maybe Document) -> IO (Maybe Document))
  -> T.Text
  -> IO (Maybe User)
checkUser run s = do
  user <- run (findUser s)
  return $ cast' . Doc =<< user

generateToken :: IO String
generateToken = do
  rngState <- newCryptoRNGState
  runCryptoRNGT rngState $ randomString 24 "abcdef0123456789"

getBlockInfo ::
     BS.ByteString -> BS.ByteString -> T.Text -> IO (Maybe BlockResponse)
getBlockInfo nodeUser nodePwd bh = do
  blockInfo <-
    makeZcashCall
      nodeUser
      nodePwd
      "getblock"
      [Data.Aeson.String bh, Number $ SC.scientific 1 0]
  let content = getResponseBody blockInfo :: RpcResponse BlockResponse
  if isNothing (err content)
    then return $ result content
    else do
      print $ err content
      return Nothing

scanTxNative :: Pipe -> T.Text -> BS.ByteString -> BS.ByteString -> IO ()
scanTxNative pipe db nodeUser nodePwd = do
  keyOwnerList <- access pipe master db findWithKeys
  unless (null keyOwnerList) $ do
    let ownerList = cast' . Doc <$> keyOwnerList
    let keyList = map (maybe "" oviewkey) ownerList
    print keyList
    lastBlockData <- access pipe master db findBlock
    latestBlock <- getBlockInfo nodeUser nodePwd "-1"
    case latestBlock of
      Nothing -> fail "No block data from node"
      Just lB -> do
        case cast' . Doc =<< lastBlockData of
          Nothing -> do
            print "Getting blocks"
            blockList <-
              mapM
                (getBlockInfo nodeUser nodePwd . T.pack . show)
                [2243000 .. (bl_height lB)]
            print "filtering blocks..."
            let filteredBlockList = filter filterBlock blockList
            print "extracting txs from blocks..."
            let txIdList = concatMap extractTxs filteredBlockList
            print "getting tx data from node..."
            txList <- mapM (getTxData nodeUser nodePwd) txIdList
            print "filtering txs..."
            let filteredTxList = map fromJust $ filter filterTx txList
            print "checking txs against keys..."
            mapM_ (checkTx filteredTxList) keyList
          Just lastBlock -> do
            let blockList' = [(bl_height lastBlock + 1) .. (bl_height lB)]
            print blockList'
  where
    filterBlock :: Maybe BlockResponse -> Bool
    filterBlock b = maybe 0 bl_confirmations b >= 5
    filterTx :: Maybe RawTxResponse -> Bool
    filterTx t =
      not (null (maybe [] rt_shieldedOutputs t)) &&
      not (null (maybe [] rt_orchardActions t))
    extractTxs :: Maybe BlockResponse -> [T.Text]
    extractTxs = maybe [] bl_txs
    getTxData ::
         BS.ByteString -> BS.ByteString -> T.Text -> IO (Maybe RawTxResponse)
    getTxData nodeUser nodePwd txid = do
      txInfo <-
        makeZcashCall
          nodeUser
          nodePwd
          "getrawtransaction"
          [Data.Aeson.String txid, Number $ SC.scientific 1 0]
      let content = getResponseBody txInfo :: RpcResponse RawTxResponse
      if isNothing (err content)
        then return $ result content
        else do
          print $ err content
          return Nothing
    checkTx :: [RawTxResponse] -> T.Text -> IO ()
    checkTx txList k = do
      if isValidSaplingViewingKey (E.encodeUtf8 k)
        then do
          print "decoding Sapling tx"
          let rawKey = decodeBech32 $ E.encodeUtf8 k
          print rawKey
          let i = concatMap rt_shieldedOutputs txList
          print i
          let decodedTxList =
                map
                  (decodeSaplingOutput $ bytes rawKey)
                  (concatMap rt_shieldedOutputs txList)
          print decodedTxList
        else do
          let vk = decodeUfvk $ E.encodeUtf8 k
          case vk of
            Nothing -> print "Not a valid key"
            Just v -> do
              let decodedSapList =
                    map
                      (decodeSaplingOutput (s_key v))
                      (concatMap rt_shieldedOutputs txList)
              print decodedSapList
              let decodedOrchList =
                    map
                      (decryptOrchardAction v)
                      (concatMap rt_orchardActions txList)
              print decodedOrchList

debug = flip trace

instance Val BlockResponse where
  cast' (Doc d) = do
    c <- B.lookup "confirmations" d
    h <- B.lookup "height" d
    t <- B.lookup "time" d
    txs <- B.lookup "tx" d
    Just (BlockResponse c h t txs)
  cast' _ = Nothing
  val (BlockResponse c h t txs) =
    Doc
      [ "confirmations" =: c
      , "height" =: h
      , "time" =: t
      , "tx" =: txs
      , "network" =: ("mainnet" :: String)
      ]

upsertBlock :: BlockResponse -> Action IO ()
upsertBlock b = do
  let block = val b
  case block of
    Doc d -> upsert (select ["network" =: ("mainnet" :: String)] "blocks") d
    _ -> return ()

findBlock :: Action IO (Maybe Document)
findBlock = findOne (select ["network" =: ("mainnet" :: String)] "blocks")