Skip to content

Commit

Permalink
Generalise Function API to allow adding and modifying new programs
Browse files Browse the repository at this point in the history 
Add three new endpoints:

* PUT: /functions/<name> Update the function with the name <name>
* POST: /functions/<name> Create a new function with the name <name>
* DELETE: /functions/<name> Delete the function with the name <name>

Refactors the code base to avoid hard-coding example programs in the
backend folder.

Add new JSON types for adding and modifying function implementations.
  • Loading branch information
@fendor
fendor committed Sep 20, 2024
1 parent ec668f6 commit 32952f3
Show file tree
Hide file tree
Showing 10 changed files with 725 additions and 435 deletions.
2 changes: 1 addition & 1 deletion lib/haskell/web-service/package.yaml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -29,7 +29,6 @@ dependencies:
- mtl
- prettyprinter
- text
- effectful
- string-interpolate
- numeric-extras
- servant ^>= 0.20.2
Expand All @@ -47,6 +46,7 @@ dependencies:
- optics
- optparse-applicative
- scientific
- stm
# Backends
- explainable
- simala
Expand Down
30 changes: 22 additions & 8 deletions lib/haskell/web-service/src/Application.hs
View file
Original file line number Diff line number Diff line change
@@ -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
Expand Down Expand Up @@ -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)
24 changes: 15 additions & 9 deletions lib/haskell/web-service/src/Backend/Api.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
}
158 changes: 23 additions & 135 deletions lib/haskell/web-service/src/Backend/Explainable.hs
View file
Original file line number Diff line number Diff line change
@@ -1,5 +1,6 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}

module Backend.Explainable (genericMathLangEvaluator) where
Expand All @@ -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
Expand Down Expand Up @@ -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)
)
Loading

0 comments on commit 32952f3

Please sign in to comment.