Skip to content

Commit

Permalink
feat(primer-service): add bounded interpreter to the HTTP APIs
Browse files Browse the repository at this point in the history 
Signed-off-by: Drew Hess <src@drewhess.com>
  • Loading branch information
@dhess
dhess committed Apr 20, 2024
1 parent 2fbc1c1 commit 45cd3a9
Show file tree
Hide file tree
Showing 9 changed files with 216 additions and 3 deletions.
10 changes: 8 additions & 2 deletions primer-api/src/Primer/API.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
1 change: 1 addition & 0 deletions primer-service/primer-service.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
7 changes: 7 additions & 0 deletions primer-service/src/Primer/Client.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -20,6 +20,7 @@ module Primer.Client (
generateNames,
evalStep,
evalFull,
evalBoundedInterp,
getProgramOpenApi,
availableActionsOpenAPI,
actionOptionsOpenAPI,
Expand All @@ -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,
Expand Down Expand Up @@ -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

Expand Down
2 changes: 2 additions & 0 deletions primer-service/src/Primer/OpenAPI.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -45,6 +45,7 @@ import Optics (
import Primer.API (
ApplyActionBody,
Def,
EvalBoundedInterpResp,
EvalFullResp,
Module,
NewSessionReq,
Expand Down Expand Up @@ -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
8 changes: 8 additions & 0 deletions primer-service/src/Primer/Servant/API.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -12,6 +12,8 @@ import Foreword

import Primer.App (
App,
EvalBoundedInterpReq (..),
EvalBoundedInterpResp (..),
EvalFullReq (..),
EvalFullResp (..),
EvalReq (..),
Expand Down Expand Up @@ -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)

Expand Down
21 changes: 20 additions & 1 deletion primer-service/src/Primer/Servant/OpenAPI.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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"
Expand Down
9 changes: 9 additions & 0 deletions primer-service/src/Primer/Server.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -68,6 +71,7 @@ import Primer.API (
createDefinition,
createTypeDef,
edit,
evalBoundedInterp',
evalFull',
findSessions,
listSessions,
Expand All @@ -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)
Expand Down Expand Up @@ -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
}
Expand Down Expand Up @@ -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))
Expand Down
13 changes: 13 additions & 0 deletions primer-service/test/Tests/OpenAPI.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -26,6 +26,7 @@ import Hedgehog.Range qualified as R
import Primer.API (
ApplyActionBody (..),
Def (Def),
EvalBoundedInterpResp (..),
EvalFullResp (EvalFullRespNormal, EvalFullRespTimedOut),
Module (Module),
NewSessionReq (..),
Expand Down Expand Up @@ -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

Expand Down Expand Up @@ -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
Expand Down
148 changes: 148 additions & 0 deletions primer-service/test/outputs/OpenAPI/openapi.json
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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": [
{
Expand Down Expand Up @@ -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",
Expand Down

0 comments on commit 45cd3a9

Please sign in to comment.