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.Maybe
import Data.SecureMem
import qualified Data.Text as T
import qualified Data.Text.Lazy as L
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Typeable
import qualified Data.Vector as V
import Data.Word
import Database.MongoDB
import Debug.Trace
import GHC.Generics
import Item
import Network.HTTP.Simple
import Network.HTTP.Types.Status
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 Text.Regex
import Text.Regex.Base
import User
import Web.Scotty
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 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

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
          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
    ZcashTx a aZ t bh bt c cm <$> arbitrary

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

-- 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 reg = matchAllText r (T.unpack m)
  let reg2 = matchAllText p (T.unpack m)
  if not (null reg)
    then do
      let sess = T.pack (fst $ head reg ! 1)
      let addy = T.pack (fst $ head reg ! 2)
      ZGoTx Nothing addy 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 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 :: T.Text -> T.Text -> T.Text -> Action IO String
sendPin nodeAddress addr pin = do
  let payload =
        [ Data.Aeson.String nodeAddress
        , Data.Aeson.Array
            (V.fromList
               [ object
                   [ "address" .= addr
                   , "amount" .= (0.00000001 :: Double)
                   , "memo" .= encodeHexText ("ZGo PIN: " ++ T.unpack pin)
                   ]
               ])
        ]
  r <- makeZcashCall "z_sendmany" payload
  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 :: Pipe -> T.Text -> T.Text -> Maybe ZGoTx -> Action IO ()
addUser _ _ _ Nothing = return () --`debug` "addUser got Nothing"
addUser p db node (Just tx) = do
  isNew <- liftIO $ isUserNew p db tx
  when isNew $ do
    let newPin = unsafePerformIO generatePin
    _ <- sendPin node (address tx) newPin
    insert_
      "users"
      [ "address" =: address tx
      , "session" =: session tx
      , "blocktime" =: blocktime tx
      , "pin" =: newPin
      , "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)

-- | Main API function
app :: Pipe -> T.Text -> SecureMem -> T.Text -> IO ()
app pipe db passkey nodeAddress = do
  let run = access pipe master db
  scotty 3000 $ do
    middleware $
      cors $
      const $
      Just
        simpleCorsResourcePolicy
          { corsRequestHeaders = ["Authorization", "Content-Type"]
          , corsMethods = "DELETE" : simpleMethods
          , corsOrigins = Nothing
          }
    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
        _ -> do
          Web.Scotty.json
            (object
               [ "message" .= ("Country data found" :: String)
               , "countries" .= toJSON (map parseCountryBson countries)
               ])
    --Get user associated with session
    get "/api/user" $ do
      sess <- param "session"
      user <- liftIO $ 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"
      user <- liftIO $ 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 providedPin
              if ans
                then do
                  liftIO $ 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"
      liftIO $ run (deleteUser userId)
      status ok200
    --Get txs from DB that have less than 10 confirmations
    {-get "/api/pending" $ do-}
      {-sess <- param "session"-}
      {-pending <- liftIO $ run (findPending sess)-}
      {-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
      addr <- param "address"
      owner <- liftIO $ 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)
                   ])
    --Upsert owner to DB
    post "/api/owner" $ do
      o <- jsonData
      let q = payload (o :: Payload Owner)
      _ <- liftIO $ run (upsertOwner q)
      status created201
    --Get items associated with the given address
    get "/api/items" $ do
      addr <- param "address"
      items <- liftIO $ 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
      _ <- liftIO $ run (upsertItem i)
      status created201
    --Delete item
    Web.Scotty.delete "/api/item/:id" $ do
      oId <- param "id"
      liftIO $ run (deleteItem oId)
      status ok200
    --Get price for Zcash
    get "/api/price" $ do
      curr <- param "currency"
      pr <- liftIO $ run (findPrice curr)
      case pr 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
      addr <- param "address"
      myOrders <- liftIO $ 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"
      myOrder <- liftIO $ 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)
                   ])
    --Get order by session
    get "/api/order" $ do
      sess <- param "session"
      myOrder <- liftIO $ 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 order
    post "/api/order" $ do
      newOrder <- jsonData
      _ <- liftIO $ run (upsertOrder newOrder)
      status created201
    --Delete order
    Web.Scotty.delete "/api/order/:id" $ do
      oId <- param "id"
      liftIO $ run (deleteOrder oId)
      status ok200

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

-- | Function to update the Zcash prices in the ZGo db
checkZcashPrices :: Pipe -> T.Text -> IO ()
checkZcashPrices p db = do
  q <- getZcashPrices
  mapM_ (access p master db) (updatePrices (getResponseBody q))

-- | Function to check the ZGo full node for new txs
scanZcash :: T.Text -> Pipe -> T.Text -> IO ()
scanZcash addr pipe db = do
  res <- makeZcashCall "z_listreceivedbyaddress" [Data.Aeson.String addr]
  let txs =
        filter (not . zchange) $
        result (getResponseBody res :: 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 . upsertPayment) j

-- | Function to generate users from login txs
updateLogins :: T.Text -> Pipe -> T.Text -> IO ()
updateLogins addr pipe db = do
  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 pipe db addr) parsed
  putStrLn "Updated logins!"

-- | 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 parsedOwner = (cast' . Doc) =<< owner
              let ownerId = o_id =<< parsedOwner
              _ <-
                access
                  pipe
                  master
                  db
                  (modify
                     (select ["_id" =: ownerId] "owners")
                     [ "$set" =:
                       [ "paid" =: True
                       , "expiration" =:
                         posixSecondsToUTCTime
                           (fromInteger (pblocktime pmt + pdelta pmt))
                       ]
                     ])
              markPaymentDone pipe db pmt

debug = flip trace