Skip to content

Commit

Permalink
Add OpenAPI specification and swagger-ui
Browse files Browse the repository at this point in the history 
In order for LLMs to interact with the REST API (which is on the goals
of the so-called LAG project), we need to provide an openapi3 compatible
API.
We do this by depending on 'servant-openapi3', and add appropriate
instances for the servant REST API.

Due to some issues, it seems like it is impossible (or very difficult),
to make custom gpts invoke REST endpoints with JSON bodies... So, for
now we simply send all parameters via Query Parameters.
Until the next servant release, we have to explicitly name all
query parameters. See
haskell-servant/servant#1604 for the PR that we
are interested in.
  • Loading branch information
@fendor
fendor committed Jul 5, 2024
1 parent 56fc3bb commit 8c1163d
Show file tree
Hide file tree
Showing 5 changed files with 648 additions and 241 deletions.
251 changes: 14 additions & 237 deletions lib/haskell/explainable/app/Main.hs
View file
Original file line number Diff line number Diff line change
@@ -1,87 +1,30 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeOperators #-}

module Main (main) where

import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Except
import Data.Aeson (FromJSON, ToJSON, (.=))
import Data.Aeson qualified as Aeson
import Data.Aeson.Types qualified as Aeson
import Data.HashMap.Strict qualified as HashMap
import Data.Map qualified as Map
import Data.Scientific (toRealFloat)
import Data.String.Interpolate (__i)
import Data.Text qualified as Text
import Explainable.MathLang
import GHC.Generics
import Network.Wai
import Network.Wai.Handler.Warp
import Network.Wai.Logger
import Options
import Options.Applicative
import Options.Applicative as Opts
import Schema
import Servant
import System.Timeout (timeout)
import Servant.Swagger.UI (SwaggerSchemaUI, swaggerSchemaUIServer)
import Server

-- ----------------------------------------------------------------------------
-- Option Parser
-- ----------------------------------------------------------------------------

opts :: ParserInfo Options
opts =
info
Opts.info
(optionsParser <**> helper)
( fullDesc
<> progDesc "Serve a Web Service for interacting with a MathLang evaluator"
<> header "explainable - A web server for MathLang"
)

-- ----------------------------------------------------------------------------
-- Servant API
-- ----------------------------------------------------------------------------

type Api = FunctionApi

type FunctionApi =
"functions"
:> (Functions :<|> FunctionsCrud)

type Functions = Get '[JSON] [SimpleFunction]

type FunctionsCrud =
Capture "name" String
:> ( ReqBody '[JSON] Attributes :> Post '[JSON] SimpleResponse
:<|> Get '[JSON] Function
)

data FlatValue
= Number Double
| Boolean Bool
deriving (Show, Read, Ord, Eq, Generic)

instance FromJSON FlatValue where
parseJSON (Aeson.Number sci) = pure $ Number $ toRealFloat sci
parseJSON (Aeson.Bool b) = pure $ Boolean b
parseJSON o =
Aeson.parseFail $ "Unexpected value, expected Number or Bool but got: " <> show o

newtype Attributes = Attributes
{ mkAttributes :: Map.Map String FlatValue
}
deriving (Show, Read, Ord, Eq, Generic)
deriving newtype (FromJSON)

data SimpleResponse
= SimpleResponse Double
| Insufficient String
deriving (Show, Read, Ord, Eq, Generic)
deriving anyclass (FromJSON, ToJSON)

-- ----------------------------------------------------------------------------
-- Main Application and wiring
-- ----------------------------------------------------------------------------
Expand All @@ -93,180 +36,14 @@ main = do
let settings = setPort port $ setLogger aplogger defaultSettings
runSettings settings app

app :: Application
app = serve (Proxy @Api) handler

-- ----------------------------------------------------------------------------
-- Web Service Handlers
-- ----------------------------------------------------------------------------

handler :: Server Api
handler =
handlerFunctions
:<|> ( \name ->
handlerFunction name
:<|> handlerParameters name
)

handlerFunctions :: Handler [SimpleFunction]
handlerFunctions = do
pure $ fmap (toSimpleFunction . snd) $ Map.elems functions
where
toSimpleFunction s =
SimpleFunction
{ simpleName = name s
, simpleDescription = description s
}

handlerFunction :: String -> Attributes -> Handler SimpleResponse
handlerFunction name query = do
case Map.lookup name functions of
Nothing -> throwError err404
Just (scenario, _) ->
case runExcept $ fromParams query of
Left err ->
pure $ Insufficient err
Right s -> do
response <- timeoutAction $ runScenario s scenario
pure $ SimpleResponse response
type ApiWithSwagger =
SwaggerSchemaUI "swagger-ui" "swagger.json"
:<|> Api

handlerParameters :: String -> Handler Function
handlerParameters name = case Map.lookup name functions of
Nothing -> throwError err404
Just (_, scenario) -> pure scenario
appWithSwagger :: Servant.Server ApiWithSwagger
appWithSwagger =
swaggerSchemaUIServer serverOpenApi
:<|> handler

timeoutAction :: IO b -> Handler b
timeoutAction act =
liftIO (timeout (seconds 5) act) >>= \case
Nothing -> throwError err505
Just r -> pure r
where
seconds n = 1_000_000 * n

-- ----------------------------------------------------------------------------
-- API specification for LLMs
-- ----------------------------------------------------------------------------

data SimpleFunction = SimpleFunction
{ simpleName :: Text.Text
, simpleDescription :: Text.Text
}
deriving (Show, Read, Ord, Eq, Generic)

data Function = Function
{ name :: Text.Text
, description :: Text.Text
, parameters :: Parameters
}
deriving (Show, Read, Ord, Eq, Generic)

newtype Parameters = Parameters Properties
deriving (Show, Read, Ord, Eq, Generic)

instance ToJSON SimpleFunction where
toJSON (SimpleFunction n desc) =
Aeson.object
[ "type" .= Aeson.String "function"
, "function"
.= Aeson.object
[ "name" .= Aeson.String n
, "description" .= Aeson.String desc
]
]

instance ToJSON Function where
toJSON (Function n desc params) =
Aeson.object
[ "type" .= Aeson.String "function"
, "function"
.= Aeson.object
[ "name" .= Aeson.String n
, "description" .= Aeson.String desc
, "parameters" .= params
]
]

instance ToJSON Parameters where
toJSON (Parameters props) =
Aeson.object
[ "type" .= Aeson.String "object"
, "properties" .= props
]

newtype Properties = Properties
{ mkProperties :: Map.Map String Parameter
}
deriving (Show, Read, Ord, Eq, Generic)
deriving newtype (ToJSON)

data Parameter = Parameter
{ parameterType :: String
, parameterEnum :: [String]
, parameterDescription :: String
}
deriving (Show, Read, Ord, Eq, Generic)

instance ToJSON Parameter where
toJSON (Parameter ty enum desc) =
Aeson.object
[ "type" .= ty
, "enum" .= enum
, "description" .= desc
]

-- ----------------------------------------------------------------------------
-- Example Rules
-- ----------------------------------------------------------------------------

runScenario :: (MonadIO m) => MyState -> Expr Double -> m Double
runScenario s scenario = do
(res, _, _, _) <- liftIO $ xplainF () s scenario
pure res

fromParams :: Attributes -> Except String MyState
fromParams attrs = do
let (valueMap, predMap) = Map.mapEither go (mkAttributes attrs)
pure $
emptyState
{ symtabF = HashMap.fromList $ Map.toList valueMap
, symtabP = HashMap.fromList $ Map.toList predMap
}
where
go (Number n) = Left $ Val Nothing n
go (Boolean b) = Right $ PredVal Nothing b

functions :: Map.Map String (Expr Double, Function)
functions =
Map.fromList
[ ("compute_qualifies", (personQualifies, personQualifiesFunction))
]

personQualifies :: Expr Double
personQualifies =
"qualifies"
@|= MathPred
( (getvar "walks") |&& ((getvar "drinks") ||| (getvar "eats"))
)

personQualifiesFunction :: Function
personQualifiesFunction =
Function
"compute_qualifies"
[__i|Determines if a person qualifies for the purposes of the rule.
The input object describes the person's properties in the primary parameters: walks, eats, drinks.
Secondary parameters can be given which are sufficient to determine some of the primary parameters.
A person drinks whether or not they consume an alcoholic or a non-alcoholic beverage, in part or in whole;
those specific details don't really matter.
The output of the function can be either a request for required information;
a restatement of the user input requesting confirmation prior to function calling;
or a Boolean answer with optional explanation summary.
|]
$ Parameters
$ Properties
$ Map.fromList
[ ("walks", Parameter "string" ["true", "false", "unknown"] "Did the person walk?")
, ("eats", Parameter "string" ["true", "false", "unknown"] "Did the person eat?")
, ("drinks", Parameter "string" ["true", "false", "unknown"] "Did the person drink?")
, ("beverage type", Parameter "string" ["alcoholic", "non-alcoholic", "unknown"] "Did the person drink an alcoholic beverage?")
, ("in whole", Parameter "string" ["true", "false", "unknown"] "Did the person drink all of the beverage?")
]
app :: Application
app = serve (Proxy @ApiWithSwagger) appWithSwagger
Loading

0 comments on commit 8c1163d

Please sign in to comment.