Experiment with DeepQuery for encoding parameters

lib/haskell/stack.yaml

@@ -41,6 +41,10 @@ extra-deps:
 - log-effectful-1.0.0.0
 - parser-combinators-1.3.0
 - monadic-recursion-schemes-0.1.13.2
+- servant-0.20.2
+- servant-server-0.20.2
+- servant-openapi3-2.0.1.6
+
 # - holmes-0.3.2.0
 # - unbound-generics-0.4.3@sha256:12209c0049000d0dd8c3eb6013d0278a8b269a2421d9758083aab9f58c4b6b4c,5446
 

lib/haskell/stack.yaml.lock

@@ -101,6 +101,27 @@ packages:
       size: 356
   original:
     hackage: monadic-recursion-schemes-0.1.13.2
+- completed:
+    hackage: servant-0.20.2@sha256:a4613dc1caa40d1b8db7aff00417dc2d651a8d73a90add3d934218b1778df35c,5371
+    pantry-tree:
+      sha256: 23364c969c171541475d270a7cf0d20ee59b4b88058deafef80b0070416670f0
+      size: 2944
+  original:
+    hackage: servant-0.20.2
+- completed:
+    hackage: servant-server-0.20.2@sha256:5a2d11959256fed8f4918f02f55cb597b61cc92191a672cd2d2228fadd5ee0ec,6226
+    pantry-tree:
+      sha256: 234c87e0a70ab6b15df75b526b344715584693be4a5c1b373ecfaaebc9c4127b
+      size: 2615
+  original:
+    hackage: servant-server-0.20.2
+- completed:
+    hackage: servant-openapi3-2.0.1.6@sha256:60be03aa18d9a2e267ec3814d3305c3bd341398dcfcdf868ab851a12a1e81591,4939
+    pantry-tree:
+      sha256: a43be8a3c3b88606dd8856006e7ad60ee70e64474e85717bfa6d580d69cb5a0b
+      size: 1637
+  original:
+    hackage: servant-openapi3-2.0.1.6
 snapshots:
 - completed:
     sha256: 98fe98dae6f42f9b4405e5467f62f57df2896c57b742a09772688c900c722510

lib/haskell/web-service/package.yaml

@@ -21,7 +21,9 @@ description:         Please see the README on GitHub at <https://github.com/gith
 dependencies:
 - base >= 4.7 && < 5
 - aeson
+- bytestring
 - containers
+- extra
 - unordered-containers
 - transformers
 - mtl
@@ -30,8 +32,8 @@ dependencies:
 - effectful
 - string-interpolate
 - numeric-extras
-- servant
-- servant-server
+- servant ^>= 0.20.2
+- servant-server ^>= 0.20.2
 - servant-openapi3
 - servant-swagger-ui
 - openapi3

lib/haskell/web-service/src/Schema.hs

@@ -17,7 +17,9 @@ import Data.Aeson qualified as Aeson
 import Data.Map (Map)
 import Data.Maybe qualified as Maybe
 import Data.OpenApi
+import Data.OpenApi qualified as OA3
 import Data.Proxy
+import Data.Text (Text)
 import Data.Text qualified as Text
 import GHC.TypeLits
 import Servant
@@ -34,6 +36,36 @@ serverOpenApi serverName =
     & info . description ?~ "API for invoking MathLang functions"
     & servers .~ Maybe.maybeToList ((\sName -> Server sName mempty mempty) <$> serverName)
 
+instance (KnownSymbol sym, ToParamSchema a, HasOpenApi sub) => HasOpenApi (DeepQuery sym a :> sub) where
+  toOpenApi _ = toOpenApi (Proxy :: Proxy sub)
+    & addParam param
+    & addDefaultResponse400 tname
+    where
+      tname = Text.pack (symbolVal (Proxy :: Proxy sym))
+      param = mempty
+        & name .~ tname
+        & in_ .~ ParamQuery
+        & schema ?~ Inline pschema
+      pschema = mempty
+        & type_ ?~ OpenApiArray
+        & items ?~ OpenApiItemsObject (Inline $ toParamSchema (Proxy :: Proxy a))
+
+-- | Add parameter to every operation in the spec.
+addParam :: OA3.Param -> OpenApi -> OpenApi
+addParam param = allOperations . OA3.parameters %~ (Inline param :)
+
+addDefaultResponse400 :: ParamName -> OpenApi -> OpenApi
+addDefaultResponse400 pname = setResponseWith (\old _new -> alter400 old) 400 (return response400)
+ where
+  sname = markdownCode pname
+  description400 = "Invalid " <> sname
+  alter400 = description %~ (<> (" or " <> sname))
+  response400 = mempty & description .~ description400
+
+-- | Format given text as inline code in Markdown.
+markdownCode :: Text -> Text
+markdownCode s = "`" <> s <> "`"
+
 instance (KnownSymbol desc, HasOpenApi api) => HasOpenApi (OperationId desc :> api) where
   toOpenApi _ =
     toOpenApi (Proxy :: Proxy api)
@@ -179,12 +211,14 @@ instance ToParamSchema FnLiteral where
 
 instance ToSchema FnLiteral where
   declareNamedSchema p = do
-    pure $ NamedSchema (Just "Literal") $ toParamSchema p
-      -- We overwrite this, as the schema itself may be one of
-      -- string, int, double or bool... And I don't think we can express that
-      -- here?
-      -- Schema validation doesn't like this set to 'OpenApiString', likely for good reason.
-      & type_ .~ Nothing
+    pure $
+      NamedSchema (Just "Literal") $
+        toParamSchema p
+          -- We overwrite this, as the schema itself may be one of
+          -- string, int, double or bool... And I don't think we can express that
+          -- here?
+          -- Schema validation doesn't like this set to 'OpenApiString', likely for good reason.
+          & type_ .~ Nothing
 
 instance ToParamSchema EvalBackends where
   toParamSchema _ =
@@ -194,4 +228,17 @@ instance ToParamSchema EvalBackends where
       & example ?~ Aeson.String "simala"
       & default_ ?~ Aeson.String "simala"
       & enum_ ?~ [Aeson.String "simala", Aeson.String "gml"]
-      & description ?~ "Backend for evaluation of a function. Backends can greatly affect how good the explanation for results. Additionally, backends may or may not support parts of natural4."
+      & description ?~ "Backend for evaluation of a function. Backends can greatly affect the explanation quality. Additionally, backends may or may not support parts of natural4."
+
+instance ToParamSchema (Map Text FnLiteral) where
+  toParamSchema _ =
+    mempty
+      & type_ ?~ OpenApiObject
+      & title ?~ "Function Arguments"
+      & example ?~ Aeson.Object
+          [ "drinks" .= Aeson.String "true"
+          , "eats" .= Aeson.String "true"
+          , "walks" .= Aeson.String "false"
+          , "amount" .= Aeson.Number 2.0
+          ]
+      & description ?~ "Provide arguments to the function to be invoked."

lib/haskell/web-service/src/Server.hs

@@ -42,6 +42,7 @@ import Data.Aeson qualified as Aeson
 import Data.Map qualified as Map
 import Data.Maybe qualified as Maybe
 import Data.String.Interpolate (__i)
+import Data.Text (Text)
 import Data.Text qualified as Text
 import Data.Typeable
 import GHC.Generics
@@ -52,6 +53,7 @@ import System.Timeout (timeout)
 import Backend.Api
 import Backend.Explainable (genericMathLangEvaluator)
 import Backend.Simala (simalaEvaluator)
+import Data.Map.Strict (Map)
 
 -- ----------------------------------------------------------------------------
 -- Servant API
@@ -91,9 +93,7 @@ data FunctionEvaluationApi mode = FunctionEvaluationApi
   { computeQualifiesFunc ::
       mode
         :- "compute_qualifies"
-          :> QueryParam "drinks" FnLiteral
-          :> QueryParam "eats" FnLiteral
-          :> QueryParam "walks" FnLiteral
+          :> DeepQuery "argument" (Map Text FnLiteral)
           :> Summary "Compute whether a person qualifies based on their properties"
           :> OperationId "runComputeQualifies"
           :> Post '[JSON] SimpleResponse
@@ -236,11 +236,13 @@ handlerFunctions = do
       }
 
 computeQualifiesHandler ::
-  Maybe EvalBackends -> Maybe FnLiteral -> Maybe FnLiteral -> Maybe FnLiteral -> Handler SimpleResponse
-computeQualifiesHandler backend drinks eats walks = do
-  let
-    args = [drinks, eats, walks]
-  runEvaluatorFor backend ComputeQualifies args
+  Maybe EvalBackends -> Map Text FnLiteral -> Handler SimpleResponse
+computeQualifiesHandler backend queryParameters = do
+  runEvaluatorFor backend ComputeQualifies
+    [ Map.lookup "drinks" queryParameters
+    , Map.lookup "walks" queryParameters
+    , Map.lookup "eats" queryParameters
+    ]
 
 rodentsAndVerminHandler ::
   Maybe EvalBackends ->