Merge pull request #620 from smucclaw/fendor/web-service/crud

Generalise Function API to allow adding and modifying new programs
smucclaw · Sep 20, 2024 · 474d301 · 474d301
2 parents 977c91c + 68f767e
commit 474d301
Show file tree

Hide file tree

Showing 11 changed files with 690 additions and 474 deletions.
diff --git a/lib/haskell/hie.yaml b/lib/haskell/hie.yaml
@@ -3,7 +3,7 @@ cradle:
     - path: "anyall/src"
       component: "anyall:lib"
 
-    - path: "anyall/app/"
+    - path: "anyall/app"
       component: "anyall:exe:anyall-exe"
 
     - path: "anyall/test"
@@ -21,6 +21,9 @@ cradle:
     - path: "natural4/src"
       component: "natural4:lib"
 
+    - path: "natural4/bnfc"
+      component: "natural4:exe:l4-bnfc-exe"
+
     - path: "natural4/app"
       component: "natural4:exe:natural4-exe"
 
@@ -33,5 +36,11 @@ cradle:
     - path: "natural4/benchmarks"
       component: "natural4:bench:natural4-bench"
 
-    - path: "natural4/bnfc"
-      component: "natural4:exe:l4-bnfc-exe"
+    - path: "web-service/src"
+      component: "web-service:lib"
+
+    - path: "web-service/app"
+      component: "web-service:exe:web-service-exe"
+
+    - path: "web-service/test"
+      component: "web-service:test:web-service-test"
diff --git a/lib/haskell/web-service/package.yaml b/lib/haskell/web-service/package.yaml
@@ -29,7 +29,6 @@ dependencies:
 - mtl
 - prettyprinter
 - text
-- effectful
 - string-interpolate
 - numeric-extras
 - servant ^>= 0.20.2
@@ -47,6 +46,7 @@ dependencies:
 - optics
 - optparse-applicative
 - scientific
+- stm
 # Backends
 - explainable
 - simala

diff --git a/lib/haskell/web-service/src/Application.hs b/lib/haskell/web-service/src/Application.hs
@@ -1,7 +1,13 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
 
 module Application (defaultMain) where
 
+import Control.Concurrent.STM (newTVarIO)
+import Control.Monad.Trans.Reader (ReaderT (..))
+import Examples qualified
 import Network.Wai
 import Network.Wai.Handler.Warp
 import Network.Wai.Logger
@@ -32,18 +38,26 @@ opts =
 defaultMain :: IO ()
 defaultMain = do
   Options{port, serverName} <- execParser opts
+  dbRef <- newTVarIO Examples.functionSpecs
+  let
+    initialState = DbState dbRef
   withStdoutLogger $ \aplogger -> do
-    let settings = setPort port $ setLogger aplogger defaultSettings
-    runSettings settings (app serverName)
+    let
+      settings = setPort port $ setLogger aplogger defaultSettings
+    runSettings settings (app initialState serverName)
 
 type ApiWithSwagger =
   SwaggerSchemaUI "swagger-ui" "swagger.json"
     :<|> Api
 
-appWithSwagger :: Maybe ServerName -> Servant.Server ApiWithSwagger
-appWithSwagger mServerName =
+appWithSwagger :: DbState -> Maybe ServerName -> Servant.Server ApiWithSwagger
+appWithSwagger initialDb mServerName =
   swaggerSchemaUIServer (serverOpenApi mServerName)
-    :<|> handler
-
-app ::  Maybe ServerName -> Application
-app mServerName = serve (Proxy @ApiWithSwagger) (appWithSwagger mServerName)
+    :<|> hoistServer (Proxy @Api) (nt initialDb) handler
+ where
+  nt :: DbState -> AppM a -> Handler a
+  nt s x = runReaderT x s
+
+app :: DbState -> Maybe ServerName -> Application
+app initialDb mServerName = do
+  serve (Proxy @ApiWithSwagger) (appWithSwagger initialDb mServerName)
diff --git a/lib/haskell/web-service/src/Backend/Api.hs b/lib/haskell/web-service/src/Backend/Api.hs
@@ -12,17 +12,15 @@ import Data.Aeson (FromJSON (..), ToJSON (..))
 import Data.Aeson qualified as Aeson
 import Data.Aeson.Types qualified as Aeson
 import Data.Scientific qualified as Scientific
+import Data.Set (Set)
+import Data.Text (Text)
 import Data.Text qualified as Text
 import Data.Text.Read qualified as TextReader
 import GHC.Generics (Generic)
 import Optics.Cons
 import Servant.API
-import Data.Text (Text)
 
-data FunctionName
-  = ComputeQualifies
-  | RodentsAndVermin
-  deriving (Show, Read, Ord, Eq)
+type FunctionName = Text
 
 data FnLiteral
   = FnLitInt !Integer
@@ -51,6 +49,18 @@ instance FromJSON FnLiteral where
       | otherwise -> Aeson.typeMismatch "Failed to parse number into bounded real or integer" (Aeson.Number val)
     obj -> Aeson.typeMismatch "Failed to parse FnLiteral" obj
 
+data Evaluator = Evaluator
+  { runEvaluatorForFunction ::
+      [(Text, Maybe FnLiteral)] ->
+      ExceptT EvaluatorError IO ResponseWithReason
+  }
+
+data FunctionDeclaration = FunctionDeclaration
+  { name :: !Text
+  , description :: !Text
+  , parameters :: !(Set Text)
+  }
+
 data ResponseWithReason = ResponseWithReason
   { responseValue :: FnLiteral
   , responseReasoning :: Reasoning
@@ -121,7 +131,3 @@ parseTextAsFnLiteral t
     ('\"', t') <- uncons t
     (t'', '\"') <- unsnoc t'
     pure t''
-
-data Evaluator = Evaluator
-  { runEvaluatorForFunction :: FunctionName -> [(Text, Maybe FnLiteral)] -> ExceptT EvaluatorError IO ResponseWithReason
-  }
diff --git a/lib/haskell/web-service/src/Backend/Explainable.hs b/lib/haskell/web-service/src/Backend/Explainable.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Backend.Explainable (genericMathLangEvaluator) where
@@ -10,24 +11,38 @@ import Control.Monad (foldM)
 import Control.Monad.Except
 import Control.Monad.IO.Class
 import Data.HashMap.Strict qualified as HashMap
-import Data.Set (Set)
 import Data.Set qualified as Set
 import Data.Text (Text)
 import Data.Text qualified as Text
 import Data.Tree qualified as Tree
 import Explainable (XP)
 import Explainable.MathLang
 
-genericMathLangEvaluator :: Evaluator
-genericMathLangEvaluator =
+genericMathLangEvaluator :: FunctionDeclaration -> Expr Double -> Evaluator
+genericMathLangEvaluator fnDecl expr =
   Evaluator
-    { runEvaluatorForFunction = \name params -> case name of
-        ComputeQualifies -> personQualifiesImpl params
-        RodentsAndVermin -> rodentsAndVerminImpl params
+    { runEvaluatorForFunction = functionHandler fnDecl expr
     }
 
-evaluator :: (MonadIO m) => MyState -> Expr Double -> ExceptT EvaluatorError m ResponseWithReason
-evaluator s scenario = do
+functionHandler :: (MonadIO m) => FunctionDeclaration -> Expr Double -> [(Text, Maybe FnLiteral)] -> ExceptT EvaluatorError m ResponseWithReason
+functionHandler decl impl args
+  | length decl.parameters /= length args =
+      throwError $
+        RequiredParameterMissing $
+          ParameterMismatch
+            { expectedParameters = length decl.parameters
+            , actualParameters = length args
+            }
+  | unknowns@(_ : _) <- filter (\(k, _) -> Set.notMember k decl.parameters) args =
+      throwError $
+        UnknownArguments $
+          fmap fst unknowns
+  | otherwise = do
+      evaluatorState <- transformParameters args
+      runExplainableInterpreter evaluatorState impl
+
+runExplainableInterpreter :: (MonadIO m) => MyState -> Expr Double -> ExceptT EvaluatorError m ResponseWithReason
+runExplainableInterpreter s scenario = do
   executionResult <- liftIO $ try (xplainF () s scenario)
   case executionResult of
     Left (e :: IOError) -> do
@@ -72,130 +87,3 @@ reasoningFromXp (Tree.Node (xpExampleCode, xpJustification) children) =
   ReasoningTree
     (ReasonNode (fmap Text.pack xpExampleCode) (fmap Text.pack xpJustification))
     (fmap reasoningFromXp children)
-
--- ----------------------------------------------------------------------------
--- Example Rules
--- ----------------------------------------------------------------------------
-
-functionHandler :: (MonadIO m) => Set Text -> [(Text, Maybe FnLiteral)] -> Expr Double -> ExceptT EvaluatorError m ResponseWithReason
-functionHandler labels arguments func
-  | length labels /= length arguments =
-      throwError $
-        RequiredParameterMissing $
-          ParameterMismatch
-            { expectedParameters = length labels
-            , actualParameters = length arguments
-            }
-  | unknowns@(_ : _) <- filter (\(k, _) -> Set.notMember k labels) arguments =
-      throwError $
-        UnknownArguments $
-          fmap fst unknowns
-  | otherwise = do
-      evaluatorState <- transformParameters arguments
-      evaluator evaluatorState func
-
-rodentsAndVerminImpl :: (MonadIO m) => [(Text, Maybe FnLiteral)] -> ExceptT EvaluatorError m ResponseWithReason
-rodentsAndVerminImpl args = functionHandler argument_labels args rodentsAndVermin
- where
-  argument_labels :: Set Text
-  argument_labels =
-    Set.fromList
-      [ "Loss or Damage.caused by insects"
-      , "Loss or Damage.caused by birds"
-      , "Loss or Damage.caused by vermin"
-      , "Loss or Damage.caused by rodents"
-      , "Loss or Damage.to Contents"
-      , "Loss or Damage.ensuing covered loss"
-      , "any other exclusion applies"
-      , "a household appliance"
-      , "a swimming pool"
-      , "a plumbing, heating, or air conditioning system"
-      ]
-
-personQualifiesImpl :: (MonadIO m) => [(Text, Maybe FnLiteral)] -> ExceptT EvaluatorError m ResponseWithReason
-personQualifiesImpl args = functionHandler argument_labels args personQualifies
- where
-  argument_labels :: Set Text
-  argument_labels =
-    Set.fromList
-      [ "drinks"
-      , "walks"
-      , "eats"
-      ]
-
--- | Example function which computes whether a person qualifies for *something*.
-personQualifies :: Expr Double
-personQualifies =
-  "qualifies"
-    @|= MathPred
-      ( getvar "walks" |&& (getvar "drinks" ||| getvar "eats")
-      )
-
-rodentsAndVermin :: Expr Double
-rodentsAndVermin =
-  "not covered"
-    @|= ( MathITE
-            (Just "Not Covered If \8230")
-            ( PredFold
-                Nothing
-                PLAnd
-                [ PredFold
-                    Nothing
-                    PLOr
-                    [ PredVar "Loss or Damage.caused by rodents"
-                    , PredVar "Loss or Damage.caused by insects"
-                    , PredVar "Loss or Damage.caused by vermin"
-                    , PredVar "Loss or Damage.caused by birds"
-                    ]
-                , PredFold
-                    Nothing
-                    PLAnd
-                    [ PredNot
-                        Nothing
-                        ( PredFold
-                            Nothing
-                            PLOr
-                            [ PredFold
-                                Nothing
-                                PLAnd
-                                [ PredVar "Loss or Damage.to Contents"
-                                , PredFold
-                                    Nothing
-                                    PLAnd
-                                    [PredVar "Loss or Damage.caused by birds"]
-                                ]
-                            , PredFold
-                                Nothing
-                                PLAnd
-                                [ PredVar "Loss or Damage.ensuing covered loss"
-                                , PredFold
-                                    Nothing
-                                    PLAnd
-                                    [ PredNot
-                                        Nothing
-                                        ( PredFold
-                                            Nothing
-                                            PLOr
-                                            [ PredVar "any other exclusion applies"
-                                            , PredFold
-                                                Nothing
-                                                PLOr
-                                                [ PredVar "a household appliance"
-                                                , PredVar "a swimming pool"
-                                                , PredVar
-                                                    "a plumbing, heating, or air conditioning system"
-                                                ]
-                                            ]
-                                        )
-                                    ]
-                                ]
-                            ]
-                        )
-                    ]
-                ]
-            )
-            -- (MathSet "Loss or Damage" (MathVar "Not Covered"))
-            --
-            (Val Nothing 1.0)
-            (Val Nothing 0.0)
-        )