work on pact-server

pact-request-api/Pact/Core/Command/Server.hs

@@ -0,0 +1,222 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Pact.Core.Command.Server
+  ( CommandEnv(..)
+  , runServer ) where
+
+import Control.Concurrent.MVar
+import Control.Lens
+import Control.Monad.Except
+import Control.Monad.IO.Class
+import qualified Data.HashMap.Strict as HM
+import Data.IORef
+import qualified Data.List as L
+import qualified Data.List.NonEmpty as NE
+import qualified Data.LruCache as LRU
+import Data.LruCache.IO as LRU
+import Data.Proxy
+import Data.Set (Set)
+import Data.Text
+import qualified Data.Text.Encoding as E
+import Data.Traversable
+import Data.Word
+import GHC.Generics
+import Network.Wai.Handler.Warp
+import Network.Wai.Middleware.Cors
+import Pact.Core.Builtin
+import Pact.Core.ChainData
+import Pact.Core.Command.Client
+import Pact.Core.Command.RPC
+import Pact.Core.Command.Server.Servant
+import Pact.Core.Command.Types
+import Pact.Core.Compile
+import Pact.Core.Environment.Types
+import Pact.Core.Errors
+import Pact.Core.Evaluate
+import Pact.Core.Gas
+import Pact.Core.Hash
+import Pact.Core.Persistence.Types
+import Pact.Core.SPV
+import Pact.Core.Info
+import Pact.Core.StableEncoding
+import qualified Pact.JSON.Decode as JD
+import qualified Pact.JSON.Encode as JE
+import qualified Pact.JSON.Legacy.Utils as JL
+import Servant.API
+import Servant.Server
+
+
+-- | Commandline configuration for running a Pact server.
+data Config = Config {
+  _port :: Word16,
+  _persistDir :: Maybe FilePath,
+  _logDir :: FilePath,
+  _pragmas :: [Pragma],
+  _verbose :: Bool,
+  _gasLimit :: Maybe Int,
+  _gasRate :: Maybe Int
+  } deriving (Eq,Show,Generic)
+
+-- | Pragma for configuring a SQLite database.
+newtype Pragma = Pragma Text
+  deriving (Eq, Show, Generic)
+
+-- | Temporarily pretend our Log type in CommandResult is unit.
+type Log = ()
+
+-- | Runtime environment for a Pact server.
+data CommandEnv
+  = CommandEnv
+  { _ceMode :: ExecutionMode
+  , _ceDbEnv :: PactDb CoreBuiltin Info
+  , _ceGasEnv :: GasEnv CoreBuiltin Info
+  , _cePublicData :: PublicData
+  , _ceSPVSupport :: SPVSupport
+  , _ceNetworkId :: Maybe NetworkId
+  , _ceExecutionConfig :: Set ExecutionFlag
+  , _ceEvalEnv :: EvalEnv CoreBuiltin Info
+  , _ceEvalState :: MVar (EvalState CoreBuiltin Info)
+  , _ceRequestCache :: LruHandle RequestKey (CommandResult Log (PactErrorCode Info))
+  }
+
+
+newtype PollRequest
+  = PollRequest (NE.NonEmpty RequestKey)
+
+instance JD.FromJSON PollRequest where
+  parseJSON = JD.withObject "Poll" $ \o -> PollRequest <$> o JD..: "requestKeys"
+
+newtype PollResponses
+  = PollResponses (HM.HashMap RequestKey (CommandResult Log (PactErrorCode Info)))
+
+instance JE.Encode PollResponses where
+  build (PollResponses m) = JE.build $ JL.legacyHashMap requestKeyToB16Text m
+
+newtype ListenRequest
+  = ListenRequest RequestKey
+
+-- instance JD.Encode ListenRequest where
+--   build (ListenRequest rk) = JD.build rk
+
+instance JD.FromJSON ListenRequest where
+  parseJSON = JD.withObject "ListenRequest" $ \o ->
+    ListenRequest <$> o JD..: "listen"
+
+newtype ListenResponse
+  = ListenResponse (CommandResult Log (PactErrorCode Info))
+
+instance JE.Encode SpanInfo where
+  build (SpanInfo ls cs le ce) = JE.object
+    [ "line_start" JE..= JE.Aeson ls
+    , "column_start" JE..= JE.Aeson cs
+    , "line_end" JE..= JE.Aeson le
+    , "column_end" JE..= JE.Aeson ce
+    ]
+
+instance JE.Encode ListenResponse where
+  build (ListenResponse r) = JE.build r
+
+instance JE.Encode Log where
+  build _ = JE.null
+
+type API = "api" :> "v1" :>
+           (("send" :> ReqBody '[JSON] SubmitBatch :> Post '[PactJson] RequestKeys)
+       :<|> ("poll" :> ReqBody '[JSON] PollRequest :> Post '[PactJson] PollResponses)
+       :<|> ("listen" :> ReqBody '[JSON] ListenRequest :> Post '[PactJson] ListenResponse)
+       :<|> ("local" :> ReqBody '[JSON] (Command Text) :> Post '[PactJson] (CommandResult Log (PactErrorCode Info))))
+
+runServer :: CommandEnv -> Port -> IO ()
+runServer env port = runSettings settings $ cors (const corsPolicy) app
+  where
+  app = serve (Proxy @API) (server env)
+  settings = defaultSettings
+    & setPort port
+    & setHost "127.0.0.1"
+  corsPolicy = Just CorsResourcePolicy
+    { corsOrigins = Nothing
+    , corsMethods = ["GET", "POST"]
+    , corsRequestHeaders = ["authorization", "content-type"]
+    , corsExposedHeaders = Nothing
+    , corsMaxAge = Just $ 60*60*24 -- one day
+    , corsVaryOrigin = False
+    , corsRequireOrigin = False
+    , corsIgnoreFailures = False
+    }
+
+server :: CommandEnv -> Server API
+server env =
+  sendHandler env
+  :<|> pollHandler env
+  :<|> listenHandler env
+  :<|> localHandler env
+
+pollHandler :: CommandEnv -> PollRequest -> Handler PollResponses
+pollHandler cenv (PollRequest rks) = do
+  h <- traverse (listenHandler cenv . ListenRequest) rks
+  let hr = NE.map (\(ListenResponse r) -> r) h
+      hres = HM.fromList $ NE.toList (NE.zip rks hr)
+  pure $ PollResponses hres
+
+sendHandler :: CommandEnv -> SubmitBatch -> Handler RequestKeys
+sendHandler env submitBatch = do
+    requestKeys <- forM (_sbCmds submitBatch) $ \cmd -> do
+      let requestKey = cmdToRequestKey cmd
+      _ <- liftIO $ cached (_ceRequestCache env) requestKey (computeResultAndUpdateState requestKey cmd)
+      pure requestKey
+    pure $ RequestKeys requestKeys
+
+    where
+        computeResultAndUpdateState :: RequestKey -> Command Text -> IO (CommandResult Log (PactErrorCode Info))
+        computeResultAndUpdateState requestKey cmd = do
+            modifyMVar (_ceEvalState env) $ \evalState -> do
+                case verifyCommand @(StableEncoding PublicMeta) (fmap E.encodeUtf8 cmd) of
+                    ProcFail _ -> error "TODO"
+                    ProcSucc Command { _cmdPayload = Payload { _pPayload = Exec execMsg }} -> do
+                        let parsedCode = Right $ _pcExps (_pmCode execMsg)
+                        (evalState', result) <- interpretReturningState (_ceEvalEnv env) evalState parsedCode
+                        case result of
+                            Right goodRes -> pure (evalState', evalResultToCommandResult requestKey goodRes)
+                            Left _ -> error "TODO"
+                    ProcSucc Command { _cmdPayload = Payload { _pPayload = Continuation contMsg }} -> do
+                        let evalInput = contMsgToEvalInput contMsg
+                        (evalState', result) <- interpretReturningState (_ceEvalEnv env) evalState evalInput
+                        case result of
+                            Right goodRes -> pure (evalState', evalResultToCommandResult requestKey goodRes)
+                            Left _ -> error "TODO"
+
+        evalResultToCommandResult :: RequestKey -> EvalResult -> CommandResult Log (PactErrorCode Info)
+        evalResultToCommandResult requestKey EvalResult {_erOutput, _erLogs, _erExec, _erGas, _erTxId, _erEvents} =
+            CommandResult {
+                _crReqKey = requestKey,
+                _crTxId = _erTxId,
+                _crResult = evalOutputToCommandResult _erOutput,
+                _crGas = _erGas,
+                _crLogs = Nothing, -- TODO
+                _crEvents = _erEvents,
+                _crContinuation = Nothing,
+                _crMetaData = Nothing -- TODO
+            }
+  -- TODO: once base-4.19 switch to L.unsnoc
+        evalOutputToCommandResult :: [CompileValue Info] -> PactResult (PactErrorCode i)
+        evalOutputToCommandResult li = case L.uncons $ L.reverse li of
+            Just (v, _) -> PactResultOk (compileValueToPactValue v)
+            Nothing -> PactResultErr undefined --PactError (PEExecutionError (EvalError "empty input") [] def)
+
+        contMsgToEvalInput :: ContMsg -> EvalInput
+        contMsgToEvalInput = undefined
+
+localHandler :: CommandEnv -> Command Text -> Handler (CommandResult Log (PactErrorCode Info))
+localHandler = undefined
+
+listenHandler :: CommandEnv -> ListenRequest -> Handler ListenResponse
+listenHandler env (ListenRequest key) = do
+    let (LRU.LruHandle cacheRef) = _ceRequestCache env
+    cache <- liftIO $ readIORef cacheRef
+    case LRU.lookup key cache of
+        Just (result, _) -> pure (ListenResponse result)
+        Nothing -> throwError err404

pact-request-api/Pact/Core/Command/Server/Servant.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
+
+-- |
+-- Module: Pact.Utils.Servant
+-- Copyright: Copyright © 2023 Kadena LLC.
+-- License: MIT
+-- Maintainer: Lars Kuhtz <[email protected]>
+-- Stability: experimental
+--
+
+module Pact.Core.Command.Server.Servant where
+
+import Data.Proxy
+import Data.Aeson
+
+import qualified Pact.JSON.Encode as J
+
+import Servant.API.ContentTypes
+import Servant.API.UVerb
+
+newtype PactJson = PactJson JSON
+  deriving newtype (Accept)
+
+instance {-# OVERLAPPABLE #-} J.Encode a => MimeRender PactJson a where
+    mimeRender _ = J.encode
+
+instance {-# OVERLAPPING #-} MimeRender PactJson a => MimeRender PactJson (WithStatus _status a) where
+  mimeRender contentTypeProxy (WithStatus a) = mimeRender contentTypeProxy a
+
+instance FromJSON a => MimeUnrender PactJson a where
+  mimeUnrender _ = mimeUnrender @JSON @a Proxy

pact-request-api/Pact/Core/Command/Types.hs

@@ -335,7 +335,7 @@ instance (FromJSON l, FromJSON err) => FromJSON (CommandResult l err) where
 instance (NFData a, NFData err) => NFData (CommandResult a err)
 
 cmdToRequestKey :: Command a -> RequestKey
-cmdToRequestKey Command {..} = RequestKey _cmdHash
+cmdToRequestKey (Command _ _ h) = RequestKey h
 
 data WebAuthnPubKeyPrefixed
   = WebAuthnPubKeyPrefixed

pact-tng.cabal

@@ -160,6 +160,7 @@ library pact-request-api
     , servant-server
     , servant
     , warp
+    , wai-cors
   exposed-modules:
     Pact.Core.Command.Types
     Pact.Core.Command.Client
@@ -168,6 +169,7 @@ library pact-request-api
     Pact.Core.Command.Util
     Pact.Core.Command.SigData
     Pact.Core.Command.Server
+    Pact.Core.Command.Server.Servant
     Pact.Core.Crypto.WebAuthn.Cose.PublicKey
     Pact.Core.Crypto.WebAuthn.Cose.PublicKeyWithSignAlg
     Pact.Core.Crypto.WebAuthn.Cose.Registry

repl/Main.hs

@@ -47,6 +47,7 @@ data ReplOpts
   | OUnsignedReq { _oReqYaml :: FilePath }
   -- Crypto
   | OGenKey
+  | OServer
   deriving (Eq, Show)
 
 replOpts :: O.Parser (Maybe ReplOpts)
@@ -57,6 +58,7 @@ replOpts = O.optional $
   <|> apiReqFlag
   <|> unsignedReqFlag
   <|> loadFlag
+  <|> O.flag' OServer (O.short 's' <> O.long "server" <> O.help "Run Pact-Server")
 
 -- Todo: trace output and coverage?
 loadFlag :: O.Parser ReplOpts
@@ -114,6 +116,10 @@ main = O.execParser argParser >>= \case
           Just s -> runScript s dbg
           Nothing -> runScript fp dbg
       | otherwise -> runScript fp dbg
+    OServer -> do
+      let commandEnv = undefined
+      let port = undefined
+      runServer commandEnv port
   where
     exitEither _ Left {} = die "Load failed"
     exitEither m (Right t) = m t >> exitSuccess