{-# 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 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(..) , DecodedNote(..) , 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 -> 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) ] ]) , Data.Aeson.Number $ SC.scientific 1 1 , Data.Aeson.Null , Data.Aeson.String "AllowRevealedAmounts" ] r <- liftIO $ try $ makeZcashCall nodeUser nodePwd "z_sendmany" pd case r of Right res -> do let sCode = getResponseStatus (res :: Response (RpcResponse T.Text)) let rBody = getResponseBody res if sCode == ok200 then do case result rBody of Nothing -> return "Couldn't parse node response" Just x -> do putStr " Sending." checkOpResult nodeUser nodePwd x return "Pin sent!" else return "Pin sending failed :(" Left ex -> return $ "Failed to send tx to node :(" ++ show (ex :: HttpException) -- | Type for Operation Result data OpResult = OpResult { opsuccess :: T.Text , opmessage :: Maybe T.Text , optxid :: Maybe T.Text } deriving (Show, Eq) instance FromJSON OpResult where parseJSON = withObject "OpResult" $ \obj -> do s <- obj .: "status" r <- obj .:? "result" e <- obj .:? "error" t <- case r of Nothing -> return Nothing Just r' -> r' .: "txid" m <- case e of Nothing -> return Nothing Just m' -> m' .: "message" pure $ OpResult s m t checkOpResult :: BS.ByteString -> BS.ByteString -> T.Text -> IO () checkOpResult user pwd opid = do response <- makeZcashCall user pwd "z_getoperationstatus" [Data.Aeson.Array (V.fromList [Data.Aeson.String opid])] let rpcResp = getResponseBody response :: (RpcResponse [OpResult]) case result rpcResp of Nothing -> putStrLn "Couldn't read response from node" Just opCode -> mapM_ showResult opCode where showResult t = case opsuccess t of "success" -> putStrLn $ " Success! Tx ID: " ++ maybe "" T.unpack (optxid t) "executing" -> do putStr "." hFlush stdout threadDelay 1000000 >> checkOpResult user pwd opid _ -> putStrLn $ " Failed :( " ++ maybe "" T.unpack (opmessage t) -- | 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 _ <- liftIO $ 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 $ C.pack q then do 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 liftAndCatchIO $ run (upsertViewingKey o' q) status created201 else status forbidden403 else case decodeUfvk (C.pack q) of Nothing -> status badRequest400 Just fvk -> if matchOrchardAddress (C.pack q) (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 liftAndCatchIO $ run (upsertViewingKey o' q) status created201 else status forbidden403 --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) [(bl_height lB - 50) .. (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 let sOutList = concatMap rt_shieldedOutputs txList' if isValidSaplingViewingKey (E.encodeUtf8 k) then do print "decoding Sapling tx" let decodedSapList' = concatMap (decodeSaplingTx k) txList' print $ filter isJust decodedSapList' 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)) sOutList print decodedSapList let decodedOrchList = map (decryptOrchardAction v) (concatMap rt_orchardActions txList') print decodedOrchList decodeSaplingTx :: T.Text -> RawTxResponse -> [Maybe ZcashTx] decodeSaplingTx k t = map (buildZcashTx t . decodeSaplingOutput (bytes (decodeBech32 $ E.encodeUtf8 k))) (rt_shieldedOutputs t) buildZcashTx :: RawTxResponse -> Maybe DecodedNote -> Maybe ZcashTx buildZcashTx t n = case n of Nothing -> Nothing Just n -> Just $ ZcashTx (rt_id t) (fromIntegral (a_value n) * 0.00000001) (toInteger $ a_value n) (rt_blockheight t) (rt_blocktime t) False (rt_confirmations t) (E.decodeUtf8Lenient $ a_memo n) 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")