KadenaPorcelain.hs

{-|

The design goal of this module is to abstract over the differences between `pact
-s` servers and full chainweb nodes. The library handles the details of
detecting what kind of server you're talking to, getting the information about
the server such as what chains are currently supported, etc. It provides a
convenient API for constructing Pact transactions, including some high level
porcelain for common transactions such as basic fungible transfers, safe
transfers, etc. It also handles detection of the ChainwebVersion and takes this
into account properly when querying pact endpoints.

Future work:

Add some more convenience functions for outputting the unsigned transaction YAML
expected by pact to facilitate the construction of transactions that can be
signed with a cold wallet.

-}

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}

module KadenaPorcelain where

------------------------------------------------------------------------------
import qualified Chainweb.Api.ChainId as CID
import           Chainweb.Api.NodeInfo
import           Control.Concurrent
import           Control.Error
import           Control.Lens hiding ((.=))
import           Control.Monad
import           Data.Aeson
import           Data.Aeson.Lens
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Base16 as B16
import           Data.Decimal
import           Data.Default
import qualified Data.HashMap.Strict as HM
import           Data.List.NonEmpty
import qualified Data.Set as S
import           Data.String
import           Data.Text (Text)
import qualified Data.Text as T
import           Data.Text.Encoding
import           Data.Time
import           Data.Time.Clock.POSIX
import           Network.Connection
import           Network.HTTP.Client
import           Network.HTTP.Client.TLS
import           Network.HTTP.Types.Status
import           Pact.ApiReq
import           Pact.Parse
import           Pact.Server.API
import           Pact.Types.API
import           Pact.Types.Capability
import           Pact.Types.ChainId
import           Pact.Types.ChainMeta
import           Pact.Types.Command
import           Pact.Types.Crypto
import           Pact.Types.Exp
import           Pact.Types.Gas
import           Pact.Types.Hash
import           Pact.Types.PactValue
import           Pact.Types.Pretty
import           Pact.Types.RPC
import           Pact.Types.Term
import           Pact.Types.Util
import           Servant.Client hiding (responseBody)
import           System.FilePath
import           Text.Printf
------------------------------------------------------------------------------

newtype NodeUrl = NodeUrl { nodeUrl :: Text }
  deriving (Eq,Ord,Show,Read,IsString)

nodeUrlStr :: NodeUrl -> String
nodeUrlStr = T.unpack . nodeUrl

data ServerType = PactServer | ChainwebServer
  deriving (Eq,Ord,Show)

data Env = Env
  { _env_server :: NodeUrl
  , _env_clientManager :: Manager
  , _env_clientEnv :: ClientEnv
  , _env_serverType :: ServerType
  , _env_nodeInfo :: Maybe NodeInfo
  -- ^ mainnet01, testnet04, etc or Nothing if it's a pact -s server
  }

getEnv :: NodeUrl -> IO (Either String Env)
getEnv h = do
    case parseRequest (T.unpack infoUrl) of
      Nothing -> return $ Left ("Could not parse '" <> nodeUrlStr h <> "'")
      Just req -> do
        mgr <- if secure req
                 then newTlsManagerWith (mkManagerSettings (TLSSettingsSimple True False False) Nothing)
                 else newManager defaultManagerSettings
        url <- parseBaseUrl (nodeUrlStr h)
        let clientEnv = mkClientEnv mgr url
        resp <- httpLbs req mgr
        if statusIsSuccessful (responseStatus resp)
          then do
            case eitherDecode (responseBody resp) of
              Left e -> return $ Left ("Error decoding response: " <> e)
              Right ni -> do
                cwUrl <- parseBaseUrl (nodeUrlStr h </> "chainweb/0.0" </> T.unpack (_nodeInfo_chainwebVer ni))
                return $ Right $ Env h mgr (mkClientEnv mgr cwUrl) ChainwebServer (Just ni)
          else do
            case parseRequest (T.unpack versionUrl) of
              Nothing -> return $ Left ("Could not parse '" <> T.unpack versionUrl <> "'")
              Just req2 -> do
                resp2 <- httpLbs req2 mgr
                if statusIsSuccessful (responseStatus resp2)
                  then return $ Right $ Env h mgr clientEnv PactServer Nothing
                  else return $ Left ("Error requesting from " <> T.unpack versionUrl)
  where
    infoUrl = nodeUrl h <> "/info"
    versionUrl = nodeUrl h <> "/version"

minPrice :: GasPrice
minPrice = GasPrice $ ParsedDecimal 0.000000000001

chain0 :: ChainId
chain0 = ChainId "0"

importKeyFile :: FilePath -> IO SomeKeyPair
importKeyFile keyFile = do
  v :: Value <- decodeYaml keyFile
  let ekp = do
        -- These keys are from genKeys in Main.hs. Might want to convert to a
        -- dedicated data type at some point.
        pub <- parseB16TextOnly =<< note "Error parsing public key" (v ^? key "public" . _String)
        sec <- parseB16TextOnly =<< note "Error parsing secret key" (v ^? key "secret" . _String)

        importKeyPair defaultScheme (Just $ PubBS pub) (PrivBS sec)
  case ekp of
    Left e -> error $ "Could not parse key file " <> keyFile <> ": " <> e
    Right kp -> return kp

getPubKey :: SomeKeyPair -> Pact.Types.Term.PublicKey
getPubKey = PublicKey . B16.encode . getPublic

keysetFromFiles :: Text -> [FilePath] -> IO KeySet
keysetFromFiles p fs = do
  keys <- mapM (fmap getPubKey . importKeyFile) fs
  return $ mkKeySet keys p

mkCap :: Maybe NamespaceName -> Text -> Text -> [PactValue] -> SigCapability
mkCap ns mn cap args = SigCapability qn args
  where
    qn = QualifiedName (ModuleName mn ns) cap def

data Tx = Tx
  { _tx_sigs :: [SomeKeyPairCaps]
  , _tx_chain :: ChainId
  , _tx_sender :: Text
  , _tx_gasLimit :: GasLimit
  , _tx_gasPrice :: GasPrice
  , _tx_creationTime :: Maybe POSIXTime
  , _tx_ttl :: Integer
  , _tx_code :: Text
  , _tx_envData :: Value
  } deriving (Show)

makeLenses ''Tx

defaultTTL :: Integer
defaultTTL = 3600

mkTx :: Text -> Text -> Value -> Tx
mkTx sender code envData = Tx [] "0" sender 600 minPrice Nothing defaultTTL code envData

mkTxChain :: ChainId -> Text -> Text -> Value -> Tx
mkTxChain cid sender code envData = Tx [] cid sender 600 minPrice Nothing defaultTTL code envData

signWithCaps :: [SigCapability] -> SomeKeyPair -> Tx -> Tx
signWithCaps caps kp = over tx_sigs ((kp, caps):)

nodePactRoot :: ServerType -> ChainId -> String
nodePactRoot PactServer _ = ""
nodePactRoot ChainwebServer c = "chain" </> T.unpack (_chainId c) </> "pact"

runPact :: (t -> ClientM a) -> Env -> ChainId -> t -> IO (Either ClientError a)
runPact theEndpoint e cid sb = do
  let ce = _env_clientEnv e
  let p = baseUrlPath (baseUrl ce) </> nodePactRoot (_env_serverType e) cid
  let pactEnv = ce { baseUrl = (baseUrl ce) { baseUrlPath = p } }
  runClientM (theEndpoint sb) pactEnv

txToExecCmd :: Tx -> Env -> IO (Command ByteString)
txToExecCmd tx e = do
  now <- (subtract 30) <$> getPOSIXTime
  let ctPosix = fromMaybe now $ _tx_creationTime tx
  let ct = TxCreationTime $ ParsedInteger $ round ctPosix
      ttl = TTLSeconds $ ParsedInteger defaultTTL
      meta = toJSON $ PublicMeta (_tx_chain tx) (_tx_sender tx) (_tx_gasLimit tx) (_tx_gasPrice tx) ttl ct
  mkCommand (_tx_sigs tx) meta (T.pack $ show $ posixSecondsToUTCTime now)
                 (NetworkId . _nodeInfo_chainwebVer <$> _env_nodeInfo e) (Exec $ ExecMsg (_tx_code tx) (_tx_envData tx))

local :: Env -> ChainId -> (Env -> IO (Command ByteString)) -> IO (Either ClientError (CommandResult Hash))
local e cid mkCmd = do
  c <- mkCmd e
  putStrLn "--- running local command ---"
  putStrLn $ T.unpack $ decodeUtf8 $ _cmdPayload c
  putStrLn "-----------------------"
  runPact localClient e cid (decodeUtf8 <$> c)

localTx :: Env -> Tx -> IO (Either ClientError (CommandResult Hash))
localTx e tx = local e (_tx_chain tx) (txToExecCmd tx)

send :: Env -> ChainId -> (Env -> IO (Command ByteString)) -> IO (Either ClientError RequestKeys)
send e cid mkCmd = do
  c <- mkCmd e
  putStrLn "--- sending command ---"
  putStrLn $ T.unpack $ decodeUtf8 $ _cmdPayload c
  putStrLn "-----------------------"
  runPact sendClient e cid (SubmitBatch ((decodeUtf8 <$> c) :| []))

toPactChainId :: CID.ChainId -> ChainId
toPactChainId = ChainId . T.pack . show . CID.unChainId

forAllChains :: Env -> (ChainId -> IO a) -> IO [a]
forAllChains e go = do
  let chains = maybe [chain0] (fmap toPactChainId . S.toList . _nodeInfo_chains) $ _env_nodeInfo e
  forM chains (\c -> go c)

sendAllChains :: Env -> (ChainId -> Env -> IO (Command ByteString)) -> IO [(ChainId, Either ClientError RequestKeys)]
sendAllChains e mkCmd = do
  forAllChains e $ \c -> do
    res <- send e c (mkCmd c)
    return (c, res)

sendTx :: Env -> Tx -> IO (Either ClientError RequestKeys)
sendTx e tx = send e (_tx_chain tx) (txToExecCmd tx)

pollRKS :: Env -> ChainId -> RequestKeys -> IO (Either ClientError PollResponses)
pollRKS e cid rks = do
  runPact pollClient e cid (Poll (_rkRequestKeys rks))

poll :: Env -> ChainId -> Text -> IO (Either ClientError PollResponses)
poll e cid rk = pollRKS e cid (RequestKeys (RequestKey h :| []))
  where
    Right h = fromText' rk

sendAndPoll
  :: Env
  -> ChainId
  -> (Env -> IO (Command ByteString))
  -> IO (Either String (HM.HashMap RequestKey (CommandResult Hash)))
sendAndPoll env cid mkCmd = do
    erks <- send env cid mkCmd
    case erks of
      Left e -> return $ Left $ show e
      Right rks -> doPoll rks
  where
    doPoll rks = do
      let delay = case _env_serverType env of
                    PactServer -> 1_000_000
                    ChainwebServer -> 10_000_000
      threadDelay delay
      pollRes <- pollRKS env cid rks
      case pollRes of
        Left e -> return $ Left $ show e
        Right (PollResponses rs) ->
          if HM.null rs then doPoll rks else return $ Right rs

getTimeNonce :: IO Text
getTimeNonce = T.pack . show <$> getCurrentTime

localPact :: NodeUrl
localPact = "http://localhost:4443"

localChainweb :: NodeUrl
localChainweb = "https://localhost:4443"

testnet :: NodeUrl
testnet = "https://us1.testnet.chainweb.com"

mainnet :: NodeUrl
mainnet = "https://api.chainweb.com"

gasCap :: SigCapability
gasCap = mkCap Nothing "coin" "GAS" []

transferCap :: Text -> Text -> Decimal -> SigCapability
transferCap f t amt = mkCap Nothing "coin" "TRANSFER" [PLiteral $ LString f, PLiteral $ LString t, PLiteral $ LDecimal amt]

-- | Unsafe function for constructing a public key from a base16 text
-- representation.  Suitable for constructing keysets with mkKeySet.
b16PubKey :: Text -> Pact.Types.Term.PublicKey
b16PubKey t = case parseB16TextOnly t of
                Left _ -> error (T.unpack t ++ " is not a valid public key")
                Right _ -> Pact.Types.Term.PublicKey $ encodeUtf8 t

renderPactDecimal :: Decimal -> Text
renderPactDecimal = renderCompactText . LDecimal

-- | Simple function for constructing a single-sig keyset guard.
keyGuard :: Pact.Types.Term.PublicKey -> Guard PactValue
keyGuard pubKey = GKeySet $ mkKeySet [pubKey] "keys-all"

------------------------------------------------------------------------------
-- Convenience functions for doing transfers.  These functions create the Tx
-- value but do not add any signatures.  It is your responsibility to add the
-- correct signatures and capabilities.

transfer :: Text -> Text -> Text -> Decimal -> ChainId -> Tx
transfer token f t amt cid =
    mkTxChain cid f code Null
  where
    code = T.pack $ printf "(%s.transfer %s %s %s)"
                           token (show f) (show t) (renderPactDecimal amt)

transferCreate :: Text -> Guard PactValue -> Text -> Text -> Decimal -> ChainId -> Tx
transferCreate token g f t amt cid =
    mkTxChain cid f code (object ["ks" .= toJSON g])
  where
    code = T.pack $ printf "(%s.transfer-create %s %s (read-keyset 'ks) %s)"
                           token (show f) (show t) (renderPactDecimal amt)

signXfer :: SomeKeyPair -> (Text -> Text -> Decimal -> ChainId -> Tx) -> Text -> Text -> Decimal -> ChainId -> Tx
signXfer fromKeyPair xferFunc f t amt cid = do
    signWithCaps [gasCap, transferCap f t amt] fromKeyPair $ xferFunc f t amt cid

-- | Constructs and signs a safe transfer transaction
safeTransfer :: SomeKeyPair -> SomeKeyPair -> Text -> Guard PactValue -> Text -> Text -> Decimal -> ChainId -> Tx
safeTransfer fromKey toKey token g f t amt cid =
    signWithCaps [gasCap, transferCap f t (amt + epsilon)] fromKey $
    signWithCaps [transferCap t f epsilon] toKey $
    set tx_gasLimit 1500 $
    mkTxChain cid f code (object ["ks" .= toJSON g])
  where
    epsilon = 0.000000000001 :: Decimal
    code = T.unlines [there, back]
    there = T.pack $ printf "(%s.transfer-create %s %s (read-keyset 'ks) (+ %s %s))"
                             token (show f) (show t) (renderPactDecimal amt) (renderPactDecimal epsilon)
    back = T.pack $ printf "(%s.transfer %s %s %s)"
                             token (show t) (show f) (renderPactDecimal epsilon)