From 45cd3a9c266595a81837d435de0fffc06a5dabfa Mon Sep 17 00:00:00 2001 From: Drew Hess Date: Thu, 18 Apr 2024 20:17:19 +0100 Subject: [PATCH] feat(primer-service): add bounded interpreter to the HTTP APIs Signed-off-by: Drew Hess --- primer-api/src/Primer/API.hs | 10 +- primer-service/primer-service.cabal | 1 + primer-service/src/Primer/Client.hs | 7 + primer-service/src/Primer/OpenAPI.hs | 2 + primer-service/src/Primer/Servant/API.hs | 8 + primer-service/src/Primer/Servant/OpenAPI.hs | 21 ++- primer-service/src/Primer/Server.hs | 9 ++ primer-service/test/Tests/OpenAPI.hs | 13 ++ .../test/outputs/OpenAPI/openapi.json | 148 ++++++++++++++++++ 9 files changed, 216 insertions(+), 3 deletions(-) diff --git a/primer-api/src/Primer/API.hs b/primer-api/src/Primer/API.hs index 295e8d16e..a3283e528 100644 --- a/primer-api/src/Primer/API.hs +++ b/primer-api/src/Primer/API.hs @@ -1388,7 +1388,13 @@ data EvalBoundedInterpResp EvalBoundedInterpRespUnknownTyCon TyConName | -- | The interpreter encountered an undefined value constructor. -- This error should never occur in a well typed program. - EvalBoundedInterpRespUnknownValCon TyConName ValConName + -- + -- Note: this should be a 'Recordpair TyConName ValConName', but + -- that doesn't serialize properly in our OpenAPI serialization + -- scheme, so instead we only include the unknwon 'ValConName' in + -- this error. See: + -- https://github.com/hackworthltd/primer/issues/1246 + EvalBoundedInterpRespUnknownValCon ValConName | -- | The evaluation succeeded. The 'Tree' represents the normal form -- of the expression being evaluated. EvalBoundedInterpRespNormal Tree @@ -1440,7 +1446,7 @@ evalBoundedInterp' = curry3 $ logAPI (noError EvalBoundedInterp') $ \(sid, timeo App.EvalBoundedInterpRespFailed Timeout -> EvalBoundedInterpRespTimeout App.EvalBoundedInterpRespFailed (NoBranch _ _) -> EvalBoundedInterpRespNoBranch App.EvalBoundedInterpRespFailed (UnknownTyCon n) -> EvalBoundedInterpRespUnknownTyCon n - App.EvalBoundedInterpRespFailed (UnknownValCon tn vn) -> EvalBoundedInterpRespUnknownValCon tn vn + App.EvalBoundedInterpRespFailed (UnknownValCon _ vn) -> EvalBoundedInterpRespUnknownValCon vn App.EvalBoundedInterpRespNormal e' -> EvalBoundedInterpRespNormal $ viewTreeExpr e' noErr :: Either Void a -> a noErr = \case diff --git a/primer-service/primer-service.cabal b/primer-service/primer-service.cabal index 3fde9b9fa..adf97a000 100644 --- a/primer-service/primer-service.cabal +++ b/primer-service/primer-service.cabal @@ -56,6 +56,7 @@ library , primer ^>=0.7.2 , primer-api ^>=0.7.2 , refined ^>=0.8 + , semirings ^>=0.6 , servant >=0.18 && <0.20.2 , servant-client >=0.18 && <0.20.2 , servant-client-core >=0.18 && <0.20.2 diff --git a/primer-service/src/Primer/Client.hs b/primer-service/src/Primer/Client.hs index 13b2f6e5d..3b0329469 100644 --- a/primer-service/src/Primer/Client.hs +++ b/primer-service/src/Primer/Client.hs @@ -20,6 +20,7 @@ module Primer.Client ( generateNames, evalStep, evalFull, + evalBoundedInterp, getProgramOpenApi, availableActionsOpenAPI, actionOptionsOpenAPI, @@ -37,6 +38,8 @@ import Primer.API qualified import Primer.Action.Available (Action, InputAction, NoInputAction, Options) import Primer.App ( App, + EvalBoundedInterpReq, + EvalBoundedInterpResp, EvalFullReq, EvalFullResp, EvalReq, @@ -167,6 +170,10 @@ evalStep sid req = apiClient // API.sessionsAPI // API.sessionAPI /: sid // API. evalFull :: SessionId -> EvalFullReq -> ClientM (Either ProgError EvalFullResp) evalFull sid req = apiClient // API.sessionsAPI // API.sessionAPI /: sid // API.evalFull /: req +-- | As 'Primer.API.evalBoundedInterp'. +evalBoundedInterp :: SessionId -> EvalBoundedInterpReq -> ClientM (Either ProgError EvalBoundedInterpResp) +evalBoundedInterp sid req = apiClient // API.sessionsAPI // API.sessionAPI /: sid // API.evalBoundedInterp /: req + availableActionsOpenAPI :: SessionId -> Level -> Primer.API.Selection -> ClientM [Action] availableActionsOpenAPI sid = openAPIClient // OpenAPI.sessionsAPI // OpenAPI.sessionAPI /: sid // OpenAPI.actions // OpenAPI.available diff --git a/primer-service/src/Primer/OpenAPI.hs b/primer-service/src/Primer/OpenAPI.hs index b640dd2f2..81abd8d1e 100644 --- a/primer-service/src/Primer/OpenAPI.hs +++ b/primer-service/src/Primer/OpenAPI.hs @@ -45,6 +45,7 @@ import Optics ( import Primer.API ( ApplyActionBody, Def, + EvalBoundedInterpResp, EvalFullResp, Module, NewSessionReq, @@ -214,3 +215,4 @@ parseQueryParamRead :: Read a => Text -> Text -> Either Text a parseQueryParamRead m t = maybeToEither ("unknown " <> m <> ": " <> t) $ readMaybe t deriving via PrimerJSON EvalFullResp instance ToSchema EvalFullResp +deriving via PrimerJSON EvalBoundedInterpResp instance ToSchema EvalBoundedInterpResp diff --git a/primer-service/src/Primer/Servant/API.hs b/primer-service/src/Primer/Servant/API.hs index 097312a8c..563d5cb01 100644 --- a/primer-service/src/Primer/Servant/API.hs +++ b/primer-service/src/Primer/Servant/API.hs @@ -12,6 +12,8 @@ import Foreword import Primer.App ( App, + EvalBoundedInterpReq (..), + EvalBoundedInterpResp (..), EvalFullReq (..), EvalFullResp (..), EvalReq (..), @@ -152,6 +154,12 @@ data SessionAPI mode = SessionAPI :> Summary "Evaluate the given expression to normal form (or time out)" :> ReqBody '[JSON] EvalFullReq :> Post '[JSON] (Either ProgError EvalFullResp) + , evalBoundedInterp :: + mode + :- "eval-bounded-interp" + :> Summary "Using the interpreter, evaluate the given expression to normal form (or time out)" + :> ReqBody '[JSON] EvalBoundedInterpReq + :> Post '[JSON] (Either ProgError EvalBoundedInterpResp) } deriving stock (Generic) diff --git a/primer-service/src/Primer/Servant/OpenAPI.hs b/primer-service/src/Primer/Servant/OpenAPI.hs index e75b4b9b2..996992777 100644 --- a/primer-service/src/Primer/Servant/OpenAPI.hs +++ b/primer-service/src/Primer/Servant/OpenAPI.hs @@ -16,7 +16,14 @@ module Primer.Servant.OpenAPI ( import Foreword import Data.OpenApi (OpenApi, ToSchema) -import Primer.API (ApplyActionBody, EvalFullResp, Prog, Selection, TypeOrKind) +import Primer.API ( + ApplyActionBody, + EvalBoundedInterpResp, + EvalFullResp, + Prog, + Selection, + TypeOrKind, + ) import Primer.Action.Available qualified as Available import Primer.App (Level) import Primer.Core (GVarName, ModuleName) @@ -88,6 +95,10 @@ data SessionsAPI mode = SessionsAPI -- | A static bound on the maximum requested timeout for evaluation endpoint type EvalFullStepLimit = 300 +-- | A static bound on the maximum requested timeout (in microseconds) +-- for evaluation via the interpreter. +type EvalBoundedInterpLimit = 100_000 -- 100ms + -- | The session-specific bits of the API. data SessionAPI mode = SessionAPI { deleteSession :: DeleteSession mode @@ -128,6 +139,14 @@ data SessionAPI mode = SessionAPI :> QueryParam "closed" NormalOrderOptions :> ReqBody '[JSON] GVarName :> Post '[JSON] EvalFullResp + , evalBoundedInterp :: + mode + :- "eval-bounded-interp" + :> Summary "Using the interpreter, evaluate the named definition to normal form (or time out)" + :> OperationId "eval-bounded-interp" + :> QueryParam "timeoutMicroseconds" (Finite 0 EvalBoundedInterpLimit) + :> ReqBody '[JSON] GVarName + :> Post '[JSON] EvalBoundedInterpResp , undo :: mode :- "undo" diff --git a/primer-service/src/Primer/Server.hs b/primer-service/src/Primer/Server.hs index 7e2578915..f4c2859ff 100644 --- a/primer-service/src/Primer/Server.hs +++ b/primer-service/src/Primer/Server.hs @@ -28,6 +28,9 @@ import Control.Monad.Log (LoggingT, WithSeverity, runLoggingT) import Control.Monad.Log qualified as Log import Data.HashMap.Strict.InsOrd qualified as IOHM import Data.OpenApi (OpenApi, Reference (Reference), Referenced (Inline, Ref), ToSchema, toSchema) +import Data.Semiring ( + fromNatural, + ) import Data.Streaming.Network.Internal (HostPreference (HostIPv4Only)) import Data.Text qualified as T import Data.Text.Lazy qualified as LT (fromStrict) @@ -68,6 +71,7 @@ import Primer.API ( createDefinition, createTypeDef, edit, + evalBoundedInterp', evalFull', findSessions, listSessions, @@ -90,6 +94,9 @@ import Primer.Database qualified as Database ( Op, ) import Primer.Eval (EvalLog) +import Primer.EvalFullInterp ( + Timeout (MicroSec), + ) import Primer.Finite (getFinite) import Primer.Log (ConvertLogMessage, logInfo, logWarning) import Primer.Name (unsafeMkName) @@ -198,6 +205,7 @@ openAPISessionServer sid = , OpenAPI.typeDef = openAPITypeDefServer sid , OpenAPI.actions = openAPIActionServer sid , OpenAPI.evalFull = evalFull' sid . fmap getFinite + , OpenAPI.evalBoundedInterp = evalBoundedInterp' sid . fmap (MicroSec . fromNatural . getFinite) , OpenAPI.undo = undo sid , OpenAPI.redo = redo sid } @@ -254,6 +262,7 @@ sessionAPIServer sid = , S.questionAPI = questionAPIServer sid , S.evalStep = API.evalStep sid , S.evalFull = API.evalFull sid + , S.evalBoundedInterp = API.evalBoundedInterp sid } questionAPIServer :: ConvertServerLogs l => SessionId -> S.QuestionAPI (AsServerT (Primer l)) diff --git a/primer-service/test/Tests/OpenAPI.hs b/primer-service/test/Tests/OpenAPI.hs index dd0190e60..71c0efa00 100644 --- a/primer-service/test/Tests/OpenAPI.hs +++ b/primer-service/test/Tests/OpenAPI.hs @@ -26,6 +26,7 @@ import Hedgehog.Range qualified as R import Primer.API ( ApplyActionBody (..), Def (Def), + EvalBoundedInterpResp (..), EvalFullResp (EvalFullRespNormal, EvalFullRespTimedOut), Module (Module), NewSessionReq (..), @@ -333,6 +334,16 @@ tasty_PaginatedMeta = testToJSON genPaginatedMeta genPaginatedSession :: Gen (Paginated Session) genPaginatedSession = Paginated <$> genPaginatedMeta <*> G.list (R.linear 0 10) genSession +genEvalBoundedInterpResp :: ExprGen EvalBoundedInterpResp +genEvalBoundedInterpResp = + G.choice + [ pure EvalBoundedInterpRespTimeout + , pure EvalBoundedInterpRespNoBranch + , EvalBoundedInterpRespUnknownTyCon <$> genTyConName + , EvalBoundedInterpRespUnknownValCon <$> genValConName + , EvalBoundedInterpRespNormal <$> genExprTree + ] + tasty_Paginated :: Property tasty_Paginated = testToJSON genPaginatedSession @@ -383,6 +394,8 @@ instance Arbitrary GVarName where arbitrary = hedgehog genGVarName instance Arbitrary EvalFullResp where arbitrary = elements [EvalFullRespNormal, EvalFullRespTimedOut] <*> hedgehog (evalExprGen 0 genExprTree) +instance Arbitrary EvalBoundedInterpResp where + arbitrary = hedgehog $ evalExprGen 0 genEvalBoundedInterpResp instance Arbitrary CreateTypeDefBody where arbitrary = CreateTypeDefBody <$> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary NewSessionReq where diff --git a/primer-service/test/outputs/OpenAPI/openapi.json b/primer-service/test/outputs/OpenAPI/openapi.json index 1ced3c85a..c492ddf7b 100644 --- a/primer-service/test/outputs/OpenAPI/openapi.json +++ b/primer-service/test/outputs/OpenAPI/openapi.json @@ -138,6 +138,97 @@ ], "type": "string" }, + "EvalBoundedInterpResp": { + "oneOf": [ + { + "properties": { + "tag": { + "enum": [ + "EvalBoundedInterpRespTimeout" + ], + "type": "string" + } + }, + "required": [ + "tag" + ], + "title": "EvalBoundedInterpRespTimeout", + "type": "object" + }, + { + "properties": { + "tag": { + "enum": [ + "EvalBoundedInterpRespNoBranch" + ], + "type": "string" + } + }, + "required": [ + "tag" + ], + "title": "EvalBoundedInterpRespNoBranch", + "type": "object" + }, + { + "properties": { + "contents": { + "$ref": "#/components/schemas/GlobalName" + }, + "tag": { + "enum": [ + "EvalBoundedInterpRespUnknownTyCon" + ], + "type": "string" + } + }, + "required": [ + "tag", + "contents" + ], + "title": "EvalBoundedInterpRespUnknownTyCon", + "type": "object" + }, + { + "properties": { + "contents": { + "$ref": "#/components/schemas/GlobalName" + }, + "tag": { + "enum": [ + "EvalBoundedInterpRespUnknownValCon" + ], + "type": "string" + } + }, + "required": [ + "tag", + "contents" + ], + "title": "EvalBoundedInterpRespUnknownValCon", + "type": "object" + }, + { + "properties": { + "contents": { + "$ref": "#/components/schemas/Tree" + }, + "tag": { + "enum": [ + "EvalBoundedInterpRespNormal" + ], + "type": "string" + } + }, + "required": [ + "tag", + "contents" + ], + "title": "EvalBoundedInterpRespNormal", + "type": "object" + } + ] + }, "EvalFullResp": { "oneOf": [ { @@ -1649,6 +1740,63 @@ "summary": "Evaluate the named definition to normal form (or time out)" } }, + "/openapi/sessions/{sessionId}/eval-bounded-interp": { + "post": { + "operationId": "eval-bounded-interp", + "parameters": [ + { + "description": "The session ID", + "in": "path", + "name": "sessionId", + "required": true, + "schema": { + "format": "uuid", + "type": "string" + } + }, + { + "in": "query", + "name": "timeoutMicroseconds", + "required": false, + "schema": { + "exclusiveMaximum": false, + "exclusiveMinimum": false, + "maximum": 100000, + "minimum": 0, + "type": "integer" + } + } + ], + "requestBody": { + "content": { + "application/json;charset=utf-8": { + "schema": { + "$ref": "#/components/schemas/GlobalName" + } + } + } + }, + "responses": { + "200": { + "content": { + "application/json;charset=utf-8": { + "schema": { + "$ref": "#/components/schemas/EvalBoundedInterpResp" + } + } + }, + "description": "" + }, + "400": { + "description": "Invalid `body` or `timeoutMicroseconds`" + }, + "404": { + "description": "`sessionId` not found" + } + }, + "summary": "Using the interpreter, evaluate the named definition to normal form (or time out)" + } + }, "/openapi/sessions/{sessionId}/name": { "get": { "operationId": "getSessionName",