Adds an OpenAI Behavior

app/Main.hs

@@ -13,7 +13,10 @@ import Control.Monad.Except
 import Control.Monad.IO.Class (liftIO)
 import Data.Foldable
 import GHC.Conc (threadDelay)
+import Network.HTTP.Client qualified as HTTP
+import Network.HTTP.Client.TLS qualified as HTTP.TLS
 import Network.Matrix.Client
+import OpenAI.Client (makeOpenAIClient)
 import Options.Applicative qualified as Opt
 import OptionsParser
 import System.Environment.XDG.BaseDir (getUserCacheDir)
@@ -23,17 +26,17 @@ main :: IO ()
 main = do
   command <- Opt.execParser parserInfo
   xdgCache <- getUserCacheDir "cofree-bot"
-
+  httpManager <- HTTP.newManager HTTP.TLS.tlsManagerSettings
   case command of
-    LoginCmd cred -> do
+    LoginCmd cred openAIKey -> do
       session <- login cred
-      matrixMain session xdgCache
-    TokenCmd TokenCredentials {..} -> do
+      matrixMain session xdgCache httpManager openAIKey
+    TokenCmd TokenCredentials {..} openAIKey -> do
       session <- createSession (getMatrixServer matrixServer) matrixToken
-      matrixMain session xdgCache
-    CLI -> cliMain xdgCache
+      matrixMain session xdgCache httpManager openAIKey
+    CLI openAIKey -> cliMain xdgCache httpManager openAIKey
 
-bot process =
+bot process manager (OpenAIKey aiKey) =
   let calcBot =
         embedTextBot $
           simplifySessionBot printCalcOutput statementP $
@@ -43,29 +46,31 @@ bot process =
       coinFlipBot' = embedTextBot $ simplifyCoinFlipBot coinFlipBot
       ghciBot' = embedTextBot $ ghciBot process
       magic8BallBot' = embedTextBot $ simplifyMagic8BallBot magic8BallBot
+      openAIBot' = runOpenAIBot (makeOpenAIClient aiKey manager 2) openAIBot 
    in calcBot
         /.\ coinFlipBot'
         /.\ helloBot
         /.\ ghciBot'
         /.\ magic8BallBot'
         /.\ updogMatrixBot
         /.\ embedTextBot jitsiBot
+        /.\ embedTextBot openAIBot'
 
-cliMain :: FilePath -> IO ()
-cliMain xdgCache = withProcessWait_ ghciConfig $ \process -> do
+cliMain :: FilePath -> HTTP.Manager -> OpenAIKey -> IO ()
+cliMain xdgCache manager openAIKey = withProcessWait_ ghciConfig $ \process -> do
   void $ threadDelay 1e6
   void $ hGetOutput (getStdout process)
   state <- readState xdgCache
-  fixedBot <- flip (fixBotPersistent xdgCache) (fold state) $ simplifyMatrixBot $ bot process
+  fixedBot <- flip (fixBotPersistent xdgCache) (fold state) $ simplifyMatrixBot $ bot process manager openAIKey
   void $ loop $ annihilate repl fixedBot
 
 unsafeCrashInIO :: Show e => ExceptT e IO a -> IO a
 unsafeCrashInIO = runExceptT >=> either (fail . show) pure
 
-matrixMain :: ClientSession -> FilePath -> IO ()
-matrixMain session xdgCache = withProcessWait_ ghciConfig $ \process -> do
+matrixMain :: ClientSession -> FilePath -> HTTP.Manager -> OpenAIKey -> IO ()
+matrixMain session xdgCache manager openAIKey = withProcessWait_ ghciConfig $ \process -> do
   void $ threadDelay 1e6
   void $ hGetOutput (getStdout process)
   state <- readState xdgCache
-  fixedBot <- flip (fixBotPersistent xdgCache) (fold state) $ hoistBot liftIO $ bot process
+  fixedBot <- flip (fixBotPersistent xdgCache) (fold state) $ hoistBot liftIO $ bot process manager openAIKey
   unsafeCrashInIO $ loop $ annihilate (matrix session xdgCache) $ batch fixedBot

app/OptionsParser.hs

@@ -1,5 +1,6 @@
 module OptionsParser where
 
+import Control.Applicative
 import Data.Text qualified as T
 import Network.Matrix.Client
 import Options.Applicative qualified as Opt
@@ -93,30 +94,46 @@ parseServer =
             "Matrix Homeserver"
       )
 
+-----------------------
+--- Behavior Config ---
+-----------------------
+
+newtype OpenAIKey = OpenAIKey T.Text
+
+parseOpenAIKey :: Opt.Parser OpenAIKey
+parseOpenAIKey =
+  OpenAIKey
+    <$> Opt.strOption
+      ( Opt.long "openai_key"
+          <> Opt.metavar "OPENAI_KEY"
+          <> Opt.help
+            "OpenAI API Key"
+      )
+
 -------------------
 --- Main Parser ---
 -------------------
 
-data Command = LoginCmd LoginCredentials | TokenCmd TokenCredentials | CLI
+data Command = LoginCmd LoginCredentials OpenAIKey | TokenCmd TokenCredentials OpenAIKey | CLI OpenAIKey
 
 mainParser :: Opt.Parser Command
 mainParser =
   Opt.subparser
     ( Opt.command
         "gen-token"
         ( Opt.info
-            (fmap LoginCmd parseLogin)
+            (liftA2 LoginCmd parseLogin parseOpenAIKey)
             (Opt.progDesc "Generate a token from a username/password")
         )
         <> Opt.command
           "run"
           ( Opt.info
-              (fmap TokenCmd parseTokenCredentials)
+              (liftA2 TokenCmd parseTokenCredentials parseOpenAIKey)
               (Opt.progDesc "Run the bot with an auth token")
           )
         <> Opt.command
           "cli"
-          (Opt.info (pure CLI) (Opt.progDesc "Run the bot in the CLI"))
+          (Opt.info (fmap CLI parseOpenAIKey) (Opt.progDesc "Run the bot in the CLI"))
     )
 
 parserInfo :: Opt.ParserInfo Command

cofree-bot.cabal

@@ -67,7 +67,10 @@ executable cofree-bot
   hs-source-dirs: app
   build-depends:
     , cofree-bot
+    , http-client
+    , http-client-tls
     , mtl
+    , openai-hs
     , optparse-applicative
     , xdg-basedir
 
@@ -93,6 +96,7 @@ library
     CofreeBot.Bot.Behaviors.Jitsi
     CofreeBot.Bot.Behaviors.Jitsi.Dictionary
     CofreeBot.Bot.Behaviors.Magic8Ball
+    CofreeBot.Bot.Behaviors.OpenAI
     CofreeBot.Bot.Behaviors.Updog
     CofreeBot.Bot.Context
     CofreeBot.Utils
@@ -110,8 +114,10 @@ library
     , lens
     , monad-loops
     , mtl
+    , openai-hs
     , pretty-simple
     , process
+    , QuasiText
     , random
     , vector
     , xdg-basedir

flake.nix

@@ -38,6 +38,20 @@
         hsPkgs = evalPkgs.haskell.packages.${compiler}.override {
           overrides = hfinal: hprev: {
             cofree-bot = hfinal.callCabal2nix "cofree-bot" ./. { };
+
+            openai-hs = hfinal.callCabal2nix "openai-hs" (evalPkgs.fetchFromGitHub {
+              owner = "agrafix";
+              repo = "openai-hs";
+              rev = "1238dfaabd065085c81d93754cfab93cecb7b471";
+              sha256 = "sha256-kkKTruinN4W4J4OutAPNYtjzPgU7pKdQhHL0JRY5ItE=";
+            } + "/openai-hs") { };
+
+            openai-servant = hfinal.callCabal2nix "openai-hs" (evalPkgs.fetchFromGitHub {
+              owner = "agrafix";
+              repo = "openai-hs";
+              rev = "1238dfaabd065085c81d93754cfab93cecb7b471";
+              sha256 = "sha256-kkKTruinN4W4J4OutAPNYtjzPgU7pKdQhHL0JRY5ItE=";
+            } + "/openai-servant") { };
           };
         };
 

src/CofreeBot/Bot/Behaviors.hs

@@ -5,6 +5,7 @@ module CofreeBot.Bot.Behaviors
     module Hello,
     module Jitsi,
     module Magic8Ball,
+    module OpenAI,
     module Updog,
   )
 where
@@ -15,4 +16,5 @@ import CofreeBot.Bot.Behaviors.GHCI as GHCI
 import CofreeBot.Bot.Behaviors.Hello as Hello
 import CofreeBot.Bot.Behaviors.Jitsi as Jitsi
 import CofreeBot.Bot.Behaviors.Magic8Ball as Magic8Ball
+import CofreeBot.Bot.Behaviors.OpenAI as OpenAI
 import CofreeBot.Bot.Behaviors.Updog as Updog

src/CofreeBot/Bot/Behaviors/OpenAI.hs

@@ -0,0 +1,83 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ViewPatterns #-}
+
+-- | A bot for general interactions with OpenAI's GPT LLM.
+module CofreeBot.Bot.Behaviors.OpenAI
+  ( openAIBot,
+    runOpenAIBot,
+  )
+where
+
+--------------------------------------------------------------------------------
+
+import CofreeBot.Bot
+import CofreeBot.Utils ((...))
+import CofreeBot.Utils.ListT (emptyListT)
+import Control.Monad.IO.Class (MonadIO (..))
+import Control.Monad.Reader (ReaderT (..), ask)
+import Control.Monad.Trans (lift)
+import Data.Attoparsec.Text
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Vector qualified as V
+import OpenAI.Client qualified as OpenAI
+import Text.QuasiText qualified as QT
+
+--------------------------------------------------------------------------------
+
+data Interaction = Interaction {prompt :: Text, completion :: Text}
+  deriving (Show, Read)
+
+prettyInteraction :: Interaction -> Text
+prettyInteraction Interaction {..} =
+  [QT.embed|
+User: $prompt
+Cofree-bot: $completion
+
+|]
+
+prettyHistory :: [Interaction] -> Text
+prettyHistory = foldMap prettyInteraction
+
+openAIBot :: Bot (ReaderT OpenAI.OpenAIClient IO) [Interaction] Text Text
+openAIBot =
+  contraMapMaybeBot (either (const Nothing) Just . parseOnly openAIBotParser) $
+    Bot $ \history i -> do
+      let prompt = buildPrompt i history
+      client <- lift ask
+      liftIO (callOpenAI client prompt) >>= \case
+        Left err -> liftIO (print err) >> emptyListT
+        Right OpenAI.TextCompletion {tcChoices} ->
+          let OpenAI.TextCompletionChoice {..} = V.head tcChoices
+              response = T.strip tccText
+           in pure (response, Interaction i response : history)
+
+runOpenAIBot :: Functor m => r -> Bot (ReaderT r m) s i o -> Bot m s i o
+runOpenAIBot r bot = hoistBot (`runReaderT` r) bot
+
+callOpenAI :: OpenAI.OpenAIClient -> OpenAI.TextCompletionCreate -> IO (Either OpenAI.ClientError OpenAI.TextCompletion)
+callOpenAI client i = OpenAI.completeText client (OpenAI.EngineId "text-davinci-003") (i {OpenAI.tccrMaxTokens = Just 2096})
+
+preamble :: Text -> [Interaction] -> Text
+preamble prompt (prettyHistory -> history) =
+  [QT.embed|
+Chat History:
+```
+$history
+```
+
+You are a friendly chat bot named Cofree-Bot on a server dedicated to functional programming.
+Given the Chat History defined above, please respond to the following prompt, but do not prepend your statmements with your name:
+
+```
+$prompt
+```
+|]
+
+buildPrompt :: Text -> [Interaction] -> OpenAI.TextCompletionCreate
+buildPrompt = OpenAI.defaultTextCompletionCreate ... preamble
+
+openAIBotParser :: Parser Text
+openAIBotParser = do
+  _ <- "chat: "
+  T.pack <$> many1 anyChar

src/CofreeBot/Utils.hs

@@ -22,6 +22,7 @@ module CofreeBot.Utils
     -- * Misc
     distinguish,
     PointedChoice (..),
+    (...),
   )
 where
 
@@ -103,3 +104,9 @@ distinguish f x
 class PointedChoice p where
   pleft :: p a b -> p (x \*/ a) (x \*/ b)
   pright :: p a b -> p (a \*/ x) (b \*/ x)
+
+infixr 9 ...
+
+-- | The blackbird operator.
+(...) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
+(...) = (.) . (.)