diff --git a/lib/haskell/stack.yaml b/lib/haskell/stack.yaml index 2d27358f6..2a30cb5b7 100644 --- a/lib/haskell/stack.yaml +++ b/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 diff --git a/lib/haskell/stack.yaml.lock b/lib/haskell/stack.yaml.lock index 5eed8c609..a64655616 100644 --- a/lib/haskell/stack.yaml.lock +++ b/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 diff --git a/lib/haskell/web-service/package.yaml b/lib/haskell/web-service/package.yaml index 58125457a..20ce7bfa5 100644 --- a/lib/haskell/web-service/package.yaml +++ b/lib/haskell/web-service/package.yaml @@ -21,7 +21,9 @@ description: Please see the README on GitHub at = 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 diff --git a/lib/haskell/web-service/src/Schema.hs b/lib/haskell/web-service/src/Schema.hs index ed91d87ea..8bc254151 100644 --- a/lib/haskell/web-service/src/Schema.hs +++ b/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." diff --git a/lib/haskell/web-service/src/Server.hs b/lib/haskell/web-service/src/Server.hs index 88b303779..b8ec9e03c 100644 --- a/lib/haskell/web-service/src/Server.hs +++ b/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 -> diff --git a/lib/haskell/web-service/web-service.cabal b/lib/haskell/web-service/web-service.cabal index 8bd393d30..116add492 100644 --- a/lib/haskell/web-service/web-service.cabal +++ b/lib/haskell/web-service/web-service.cabal @@ -39,10 +39,12 @@ library build-depends: aeson , base >=4.7 && <5 + , bytestring , containers , directory , effectful , explainable + , extra , filepath , lens , mtl @@ -53,9 +55,9 @@ library , optparse-applicative , prettyprinter , scientific - , servant + , servant >=0.20.2 && <0.21 , servant-openapi3 - , servant-server + , servant-server >=0.20.2 && <0.21 , servant-swagger-ui , simala , string-interpolate @@ -77,10 +79,12 @@ executable web-service-exe build-depends: aeson , base >=4.7 && <5 + , bytestring , containers , directory , effectful , explainable + , extra , filepath , lens , mtl @@ -91,9 +95,9 @@ executable web-service-exe , optparse-applicative , prettyprinter , scientific - , servant + , servant >=0.20.2 && <0.21 , servant-openapi3 - , servant-server + , servant-server >=0.20.2 && <0.21 , servant-swagger-ui , simala , string-interpolate @@ -121,10 +125,12 @@ test-suite web-service-test QuickCheck , aeson , base >=4.7 && <5 + , bytestring , containers , directory , effectful , explainable + , extra , filepath , hspec , lens @@ -137,9 +143,9 @@ test-suite web-service-test , prettyprinter , quickcheck-instances , scientific - , servant + , servant >=0.20.2 && <0.21 , servant-openapi3 - , servant-server + , servant-server >=0.20.2 && <0.21 , servant-swagger-ui , simala , string-interpolate