zgo-backend/src/ZGoBackend.hs

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

module ZGoBackend where

import Control.Concurrent (forkIO, threadDelay)
import Control.Monad
import Control.Monad.IO.Class
import Data.Aeson
import Data.Array
import qualified Data.Bson as B
import qualified Data.ByteString as BS
import Data.Char
import qualified Data.HashMap.Strict as HM
import Data.SecureMem
import qualified Data.Text as T
import qualified Data.Text.Lazy as L
import Data.Time.Clock
import qualified Data.Vector as V
import Database.MongoDB
import GHC.Generics
import Network.HTTP.Simple
import Network.HTTP.Types.Status
import Network.Wai.Middleware.HttpAuth
import Numeric
import System.IO.Unsafe
import System.Random
import Test.QuickCheck
import Test.QuickCheck.Instances
import Text.Regex
import Text.Regex.Base
import Web.Scotty

-- 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 T.Text
    , respId :: T.Text
    , result :: r
    }
  deriving (Show, Generic, ToJSON)

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

-- | Type to model a (simplified) block of Zcash blockchain
data Block =
  Block
    { height :: Integer
    , size :: Integer
    }
  deriving (Show, Generic, ToJSON)

instance FromJSON Block where
  parseJSON (Object obj) = Block <$> obj .: "height" <*> obj .: "size"
  parseJSON _ = mzero

-- | Type to model a Zcash shielded transaction
data ZcashTx =
  ZcashTx
    { 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
          c
          conf
          (T.pack (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
    m <- arbitrary
    return $ ZcashTx a aZ t bh bt c cm m

-- | Helper function to turn a hex-encoded memo strings to readable text
decodeHexText :: String -> String
decodeHexText hexText
  -- | chunk == "00" = decodeHexText (drop 2 hexText)
  | null chunk = ""
  | otherwise = chr (read ("0x" <> chunk)) : decodeHexText (drop 2 hexText)
  where
    chunk = take 2 hexText

-- | Helper function to turn a string into a hex-encoded string
encodeHexText :: String -> String
encodeHexText t = mconcat (map padHex t)
  where
    padHex x =
      if ord x < 16
        then "0" ++ (showHex . ord) x ""
        else showHex (ord x) ""

-- | Helper function to pad a string to a given length
padLeft :: String -> Char -> Int -> String
padLeft s c m =
  let isBaseLarger = length s > m
      padder s c m False = [c | _ <- [1 .. (m - length s)]] ++ s
      padder s _ _ True = s
   in padder s c m isBaseLarger

generatePin :: IO T.Text
generatePin = do
  g <- newStdGen
  pure $
    T.pack (padLeft (show . head $ randomRs (1 :: Integer, 10000000) g) '0' 7)

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

-- | Type to represent a ZGo User, i.e.: a specific device
data User =
  User
    { _id :: String
    , address :: T.Text
    , session :: T.Text
    , blocktime :: Integer
    , pin :: T.Text
    , validated :: Bool
    }
  deriving (Eq, Show, Generic, ToJSON)

parseUserBson :: B.Document -> Maybe User
parseUserBson d = do
  i <- B.lookup "_id" d
  a <- B.lookup "address" d
  s <- B.lookup "session" d
  b <- B.lookup "blocktime" d
  p <- B.lookup "pin" d
  v <- B.lookup "validated" d
  pure $ User (show (i :: B.ObjectId)) a s b p v

-- | Type to model a ZGo transaction
data ZGoTx =
  ZGoTx
    { _id :: String
    , address :: T.Text
    , session :: T.Text
    , confirmations :: Integer
    , blocktime :: Integer
    , amount :: Double
    , txid :: T.Text
    , memo :: T.Text
    }
  deriving (Eq, Show, Generic, ToJSON)

parseZGoTxBson :: B.Document -> Maybe ZGoTx
parseZGoTxBson d = do
  i <- B.lookup "_id" d
  a <- B.lookup "address" d
  s <- B.lookup "session" d
  c <- B.lookup "confirmations" d
  am <- B.lookup "amount" d
  t <- B.lookup "txid" d
  m <- B.lookup "memo" d
  bt <- B.lookup "blocktime" d
  pure $ ZGoTx (show (i :: B.ObjectId)) a s c bt am t m

encodeZGoTxBson :: ZGoTx -> B.Document
encodeZGoTxBson (ZGoTx i a s c bt am t m) =
  if not (null i)
    then [ "_id" =: i
         , "address" =: a
         , "session" =: s
         , "confirmations" =: c
         , "blocktime" =: bt
         , "amount" =: am
         , "txid" =: t
         , "memo" =: m
         ]
    else [ "address" =: a
         , "session" =: s
         , "confirmations" =: c
         , "blocktime" =: bt
         , "amount" =: am
         , "txid" =: t
         , "memo" =: m
         ]

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 reg = matchAllText r (T.unpack m)
  let reg2 = matchAllText p (T.unpack m)
  if not (null reg)
    then do
      let session = T.pack (fst $ head reg ! 1)
      let addy = T.pack (fst $ head reg ! 2)
      ZGoTx "" addy session conf bt a t m
    else do
      if not (null reg2)
        then do
          let session = T.pack (fst $ head reg2 ! 1)
          ZGoTx "" "" session conf bt a t m
        else ZGoTx "" "" "" 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 :: String
    }
  deriving (Eq, Show, Generic, ToJSON)

parseZGoPrice :: B.Document -> Maybe ZGoPrice
parseZGoPrice d = do
  i <- B.lookup "_id" d
  c <- B.lookup "currency" d
  p <- B.lookup "price" d
  t <- B.lookup "timestamp" d
  pure $ ZGoPrice (show (i :: B.ObjectId)) c p (show (t :: B.Value))

-- | Type for the CoinGecko response
newtype CoinGeckoPrices =
  CoinGeckoPrices [(T.Text, Double)]
  deriving (Eq, Show)

instance FromJSON CoinGeckoPrices where
  parseJSON =
    withObject "CoinGeckoPrices" $ \obj -> do
      z <- obj .: "zcash"
      pure $ CoinGeckoPrices (HM.toList z)

-- Functions for querying the ZGo database
-- | Function to query DB for countries list
listCountries :: Action IO [Document]
listCountries = rest =<< find (select [] "countries")

-- | Function to query DB for unexpired user by session ID
findUser :: T.Text -> Action IO (Maybe Document)
findUser s = findOne (select ["session" =: s] "users")

-- | Function to create user from ZGoTx
addUser :: T.Text -> ZGoTx -> Action IO ()
addUser node (ZGoTx i a s c bt am t m) = do
  let newPin = unsafePerformIO generatePin
  let msg = sendPin node a newPin
  insert_
    "users"
    [ "address" =: a
    , "session" =: s
    , "blocktime" =: bt
    , "pin" =: newPin
    , "validated" =: False
    ]

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

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

-- | Main API function
app :: Pipe -> T.Text -> SecureMem -> T.Text -> IO ()
app pipe db passkey nodeAddress = do
  let run = access pipe master db
  scotty 4000 $ do
    middleware $
      basicAuth
        (\u p -> return $ u == "user" && secureMemFromByteString p == passkey)
        "ZGo Backend"
    --Get list of countries for UI
    get "/api/countries" $ do
      countries <- liftIO $ run listCountries
      case countries of
        [] -> do
          status noContent204
          Web.Scotty.json
            (object ["message" .= ("No countries available" :: String)])
        _ -> do
          Web.Scotty.json
            (object
               [ "message" .= ("Country data found" :: String)
               , "countries" .= toJSON (map parseCountryBson countries)
               ])
    --Get user associated with session
    get "/api/user" $ do
      session <- param "session"
      user <- liftIO $ run (findUser session)
      case user of
        Nothing -> status noContent204
        Just u ->
          Web.Scotty.json
            (object
               [ "message" .= ("User found" :: String)
               , "user" .= toJSON (parseUserBson u)
               ])
    --Add user
    post "/api/user" $ do text "Added that guy"
    --Delete user
    Web.Scotty.delete "/api/user/:id" $ do text "Deleted that guy!"
    --Get txs from DB that have less than 10 confirmations
    get "/api/pending" $ do
      session <- param "session"
      pending <- liftIO $ run (findPending session)
      case pending of
        [] -> do
          status noContent204
        _ -> do
          Web.Scotty.json
            (object
               [ "message" .= ("Found pending transactions" :: String)
               , "txs" .= toJSON (map parseZGoTxBson pending)
               ])
    --Get current blockheight from Zcash node
    get "/api/blockheight" $ do
      blockInfo <- makeZcashCall "getblock" ["-1"]
      Web.Scotty.json (result (getResponseBody blockInfo :: RpcResponse Block))
    --Get transactions associated with ZGo node
    --get "/api/txs" $ do
      --txs <- makeZcashCall "z_listreceivedbyaddress" [nodeAddress]
      --Web.Scotty.json (result (getResponseBody txs :: RpcResponse [ZcashTx]))
    --Get the ZGo node's shielded address
    get "/api/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress])
    --Get owner by address
    get "/api/owner" $ do text "Here's an owner for you"
    --Upsert owner to DB
    post "/api/owner" $ do text "I added an owner for you"
    --Validate user, updating record
    post "/api/validateuser" $ do text "Marked user as validated"
    --Get items associated with the given address
    get "/api/items" $ do text "Here are your items"
    --Upsert item
    post "/api/item" $ do text "I upserted the item for you"
    --Delete item
    Web.Scotty.delete "/api/item/:id" $ do text "Deleted that pesky item"
    --Get price for Zcash
    get "/api/price" $ do
      currency <- param "currency"
      price <- liftIO $ run (findPrice currency)
      case price of
        Nothing -> do
          status noContent204
          --Web.Scotty.json (object ["message" .= ("No price" :: T.Text)])
        Just p -> do
          Web.Scotty.json
            (object
               [ "message" .= ("Price found!" :: String)
               , "price" .= toJSON (parseZGoPrice p)
               ])
    --Get all closed orders for the address
    get "/api/allorders" $ do text "Here are the orders"
    --Get order by id for receipts
    get "/api/order/:id" $ do
      oId <- param "id"
      text (L.pack ("Here's the order" <> oId))
    --Get order by session
    get "/api/order" $ do
      diff <- param "diff"
      text (L.pack ("This is a diff order" <> diff))
    --Upsert order
    post "/api/order" $ do text "Upserted your order"

-- |Make a Zcash RPC call
makeZcashCall ::
     (MonadIO m, FromJSON a) => T.Text -> [Data.Aeson.Value] -> m (Response a)
makeZcashCall m p = do
  let username = "zecwallet"
  let password = "rdsxlun6v4a"
  let payload =
        RpcCall {jsonrpc = "1.0", callId = "test", method = m, parameters = p}
  let myRequest =
        setRequestBodyJSON payload $
        setRequestPort 8232 $
        setRequestBasicAuth username password $
        setRequestMethod "POST" defaultRequest
  httpJSON myRequest

-- |Timer for repeating actions
setInterval :: Int -> IO () -> IO ()
setInterval secs func = do
  forever $ threadDelay (secs * 1000000) >> func

-- |Function to query the CoinGecko API for the price of Zcash
getZcashPrices :: IO (Response CoinGeckoPrices)
getZcashPrices = do
  let priceRequest =
        setRequestQueryString
          [("ids", Just "zcash"), ("vs_currencies", Just "usd,gbp,eur,cad,aud")] $
        setRequestPort 443 $
        setRequestSecure True $
        setRequestHost "api.coingecko.com" $
        setRequestPath "/api/v3/simple/price" defaultRequest
  httpJSON priceRequest

checkZcashPrices :: Pipe -> T.Text -> IO ()
checkZcashPrices p db = do
  q <- getZcashPrices
  mapM_ (access p master db) (updatePrices (getResponseBody q))

scanZcash :: T.Text -> Pipe -> T.Text -> IO ()
scanZcash addr pipe db = do
  r <- makeZcashCall "z_listreceivedbyaddress" [Data.Aeson.String addr]
  let txs =
        filter (not . zchange) $
        result (getResponseBody r :: RpcResponse [ZcashTx])
  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 k = map zToZGoTx (filter (matchTest r . T.unpack . zmemo) txs)
  mapM_ (access pipe master db . upsertZGoTx "txs") k
  let j = map zToZGoTx (filter (matchTest p . T.unpack . zmemo) txs)
  mapM_ (access pipe master db . upsertZGoTx "payments") j