{-# LANGUAGE OverloadedStrings #-}

-- | One-shot host algebra over circuits-agent seats.
--
-- A 'Host' is a named effectful seat that receives arguments drawn from the
-- body of an incoming post and produces lines of output.  Live CLI agents
-- are 'Cli' recipes from 'Circuit.Agent.Cli' — session management (scrape,
-- resume, stale fallback) lives there, not here.
module Free.Agent.Host
  ( BodyMode (..),
    Host (..),
    BareConfig (..),
    mkHost,
    hostShard,
    processHost,
    cliHost,
    hermesHost,
    hermesHostBatch,
    hermesCli,
    kimiHost,
    bareHost,
    defaultBareConfig,
  )
where

import Circuit.Agent (Post (..), mkPost)
import Circuit.Agent.Tensor (AgentShard, ioShard)
import Circuit.Parser.Json (Json (..), decodeJson, encodeJson)
import Data.ByteString.Char8 qualified as BC8
import Data.ByteString.Lazy qualified as BL
import Data.IORef (IORef)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Vector qualified as V
import Free.Agent.Cli (Cli (..), StderrPolicy (..), cleanCliOut, cliQuery, kimiCli, parseSessionId)
import Network.HTTP.Client
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Types.Status (statusCode)
import System.Process (readProcess)

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Free.Agent.Host
-- >>> import Circuit.Agent

-- | How to turn a post body into arguments for 'hostRun'.
data BodyMode
  = -- | Split on whitespace (default).
    BodyWords
  | -- | Split on newlines.
    BodyLines
  | -- | Pass the whole body as a single argument.
    BodyWhole
  deriving (Int -> BodyMode -> ShowS
[BodyMode] -> ShowS
BodyMode -> String
(Int -> BodyMode -> ShowS)
-> (BodyMode -> String) -> ([BodyMode] -> ShowS) -> Show BodyMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BodyMode -> ShowS
showsPrec :: Int -> BodyMode -> ShowS
$cshow :: BodyMode -> String
show :: BodyMode -> String
$cshowList :: [BodyMode] -> ShowS
showList :: [BodyMode] -> ShowS
Show, BodyMode -> BodyMode -> Bool
(BodyMode -> BodyMode -> Bool)
-> (BodyMode -> BodyMode -> Bool) -> Eq BodyMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BodyMode -> BodyMode -> Bool
== :: BodyMode -> BodyMode -> Bool
$c/= :: BodyMode -> BodyMode -> Bool
/= :: BodyMode -> BodyMode -> Bool
Eq)

-- | A one-shot host seat.
--
-- The host receives arguments derived from the body of an incoming post and
-- produces output lines.  The caller decides how to turn those lines back into
-- posts; 'hostShard' uses the default mapping (reply to sender).
data Host = Host
  { -- | Name used as the 'from' field of reply posts.
    Host -> Text
hostName :: Text,
    -- | How to split the incoming post body before calling 'hostRun'.
    Host -> BodyMode
hostBodyMode :: BodyMode,
    -- | Run the host on the prepared arguments.
    Host -> [Text] -> IO [Text]
hostRun :: [Text] -> IO [Text]
  }

-- | Smart constructor with the default 'BodyWords' mode.
mkHost :: Text -> ([Text] -> IO [Text]) -> Host
mkHost :: Text -> ([Text] -> IO [Text]) -> Host
mkHost Text
name [Text] -> IO [Text]
f = Text -> BodyMode -> ([Text] -> IO [Text]) -> Host
Host Text
name BodyMode
BodyWords [Text] -> IO [Text]
f

-- | Split a post body according to the host's 'BodyMode'.
bodyArgs :: BodyMode -> Text -> [Text]
bodyArgs :: BodyMode -> Text -> [Text]
bodyArgs BodyMode
BodyWords = Text -> [Text]
T.words
bodyArgs BodyMode
BodyLines = Text -> [Text]
T.lines
bodyArgs BodyMode
BodyWhole = (Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [])

-- | Turn a host into a stateful shard that consumes every committed post.
--
-- The shard remembers the committed posts in its state.  On emit it runs the
-- host on each post's body (prepared by 'hostBodyMode'), in order, and emits
-- one reply post per output line per input post.  Each reply is addressed back
-- to the sender of its input post.
--
-- Note: a generic host has no access to stamped log ids, so emitted replies
-- carry no thread edge.  Callers that need provenance should thread by id
-- outside the host.
hostShard :: Host -> AgentShard [Post Text] [Post Text]
hostShard :: Host -> AgentShard [Post Text] [Post Text]
hostShard Host
h =
  ([Post Text] -> IO [Post Text])
-> AgentShard [Post Text] [Post Text]
ioShard (([Post Text] -> IO [Post Text])
 -> AgentShard [Post Text] [Post Text])
-> ([Post Text] -> IO [Post Text])
-> AgentShard [Post Text] [Post Text]
forall a b. (a -> b) -> a -> b
$
    ([[Post Text]] -> [Post Text])
-> IO [[Post Text]] -> IO [Post Text]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Post Text]] -> [Post Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      (IO [[Post Text]] -> IO [Post Text])
-> ([Post Text] -> IO [[Post Text]])
-> [Post Text]
-> IO [Post Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Post Text -> IO [Post Text]) -> [Post Text] -> IO [[Post Text]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse
        ( \Post Text
p -> do
            outs <- Host -> [Text] -> IO [Text]
hostRun Host
h (BodyMode -> Text -> [Text]
bodyArgs (Host -> BodyMode
hostBodyMode Host
h) (Post Text -> Text
forall a. Post a -> a
body Post Text
p))
            pure [mkPost (hostName h) [from p] o | o <- outs]
        )

-- | A host backed by an external process.
--
-- The command receives the fixed @args@ followed by the prepared post body
-- (one argument when 'BodyWhole', whitespace-split words by default).  Output
-- lines become reply posts.  Uses 'System.Process.readProcess'.
processHost ::
  -- | Host name.
  Text ->
  -- | Command to run.
  FilePath ->
  -- | Fixed command arguments.
  [String] ->
  Host
processHost :: Text -> String -> [String] -> Host
processHost Text
name String
cmd [String]
args =
  Host
    { hostName :: Text
hostName = Text
name,
      hostBodyMode :: BodyMode
hostBodyMode = BodyMode
BodyWhole,
      hostRun :: [Text] -> IO [Text]
hostRun = \[Text]
ws -> do
        out <- String -> [String] -> String -> IO String
readProcess String
cmd ([String]
args [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack [Text]
ws) String
""
        pure (map T.pack (lines out))
    }

-- | A host backed by a live CLI agent recipe ('Circuit.Agent.Cli').
--
-- Each prepared body becomes one 'cliQuery'; session scrape/resume/stale
-- fallback happens inside the recipe.  One reply text per body (multi-line
-- bodies and replies are preserved).
cliHost ::
  -- | Host name (used as the 'from' field of reply posts).
  Text ->
  -- | Invocation recipe.
  Cli ->
  Host
cliHost :: Text -> Cli -> Host
cliHost Text
name Cli
cli =
  Host
    { hostName :: Text
hostName = Text
name,
      hostBodyMode :: BodyMode
hostBodyMode = BodyMode
BodyWhole,
      hostRun :: [Text] -> IO [Text]
hostRun = (Text -> IO Text) -> [Text] -> IO [Text]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Cli -> Text -> IO Text
cliQuery Cli
cli)
    }

-- | Kimi host on the shared 'Cli' seat.
--
-- Runs @kimi -p@ per body (see 'kimiCli'), with optional @-m <model>@,
-- @--provider <provider>@, and session resume via @sessionFile@.  A stale
-- session falls back to fresh.
--
-- When @mTranscript@ is 'Just', one JSONL transcript record is appended to
-- the given file per invocation.  The caller writes the post id to the
-- 'IORef' before each call; see 'Free.Agent.Cli.cliQuery' for details.
kimiHost ::
  -- | Host name (used as the 'from' field of reply posts).
  Text ->
  -- | Model name passed to @kimi -m@, if any.
  Maybe Text ->
  -- | Provider passed to @kimi --provider@, if any.
  Maybe Text ->
  -- | Session file for cross-call context.
  FilePath ->
  -- | Optional transcript sink.
  Maybe (IORef Int, FilePath) ->
  Host
kimiHost :: Text
-> Maybe Text
-> Maybe Text
-> String
-> Maybe (IORef Int, String)
-> Host
kimiHost Text
name Maybe Text
model Maybe Text
provider String
sessionFile Maybe (IORef Int, String)
mTranscript =
  Text -> Cli -> Host
cliHost Text
name (Maybe Text -> Maybe Text -> String -> Cli
kimiCli Maybe Text
model Maybe Text
provider String
sessionFile) {cliTranscript = mTranscript}

-- | Hermes host on the shared 'Cli' seat.
--
-- Runs @hermes chat -q@ per body, prepending the supplied system prompt to
-- the body in the query.  The optional model and provider override the CLI
-- defaults; @Nothing@ keeps the hermes CLI default.  @yolo@ controls whether
-- @--yolo -Q@ is passed to hermes.
-- Sessions persist across calls via @sessionFile@; a stale session falls
-- back to fresh.
--
-- When @mTranscript@ is 'Just', one JSONL transcript record is appended to
-- the given file per invocation.  The caller writes the post id to the
-- 'IORef' before each call; see 'Free.Agent.Cli.cliQuery' for details.
--
-- The caller is responsible for building the system prompt; this function
-- knows nothing about design documents, protocol cards, or magic wording.
hermesHost ::
  -- | Host name (used as the 'from' field of reply posts).
  Text ->
  -- | System prompt text prepended to every body.
  Text ->
  -- | Model name passed to @hermes -m@, if any.
  Maybe Text ->
  -- | Provider passed to @hermes --provider@, if any.
  Maybe Text ->
  -- | Pass @--yolo -Q@ to hermes.
  Bool ->
  -- | Session file for cross-call context.
  FilePath ->
  -- | Optional transcript sink.
  Maybe (IORef Int, FilePath) ->
  Host
hermesHost :: Text
-> Text
-> Maybe Text
-> Maybe Text
-> Bool
-> String
-> Maybe (IORef Int, String)
-> Host
hermesHost Text
name Text
systemPrompt Maybe Text
model Maybe Text
provider Bool
yolo String
sessionFile Maybe (IORef Int, String)
mTranscript =
  Host
    { hostName :: Text
hostName = Text
name,
      hostBodyMode :: BodyMode
hostBodyMode = BodyMode
BodyWhole,
      hostRun :: [Text] -> IO [Text]
hostRun = (Text -> IO Text) -> [Text] -> IO [Text]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Text -> IO Text
runOne
    }
  where
    runOne :: Text -> IO Text
runOne Text
body =
      Cli -> Text -> IO Text
cliQuery Cli
cli (Text
systemPrompt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\nUser message:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
body)
    cli :: Cli
cli = Maybe Text
-> Maybe Text -> Bool -> String -> Maybe (IORef Int, String) -> Cli
hermesCli Maybe Text
model Maybe Text
provider Bool
yolo String
sessionFile Maybe (IORef Int, String)
mTranscript

-- | Shared CLI recipe for hermes backends.
-- When @cliTranscript@ is 'Just', one JSONL record is appended per invocation.
hermesCli :: Maybe Text -> Maybe Text -> Bool -> FilePath -> Maybe (IORef Int, FilePath) -> Cli
hermesCli :: Maybe Text
-> Maybe Text -> Bool -> String -> Maybe (IORef Int, String) -> Cli
hermesCli Maybe Text
model Maybe Text
provider Bool
yolo String
sessionFile Maybe (IORef Int, String)
mTranscript =
  Cli
    { cliCommand :: String
cliCommand = String
"hermes",
      cliArgv :: Text -> Maybe Text -> [String]
cliArgv = \Text
prompt Maybe Text
mSid ->
        [String
"chat", String
"-q", Text -> String
T.unpack Text
prompt]
          [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String] -> (Text -> [String]) -> Maybe Text -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
m -> [String
"-m", Text -> String
T.unpack Text
m]) Maybe Text
model
          [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String] -> (Text -> [String]) -> Maybe Text -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
p -> [String
"--provider", Text -> String
T.unpack Text
p]) Maybe Text
provider
          [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> (if Bool
yolo then [String
"--yolo", String
"-Q"] else [])
          [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String] -> (Text -> [String]) -> Maybe Text -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
sid -> [String
"--resume", Text -> String
T.unpack Text
sid]) Maybe Text
mSid,
      cliStdin :: Text -> String
cliStdin = String -> Text -> String
forall a b. a -> b -> a
const String
"",
      cliSessionFile :: String
cliSessionFile = String
sessionFile,
      cliSessionId :: Text -> Maybe Text
cliSessionId = Text -> Maybe Text
parseSessionId,
      cliStale :: ExitCode -> Text -> Bool
cliStale = \ExitCode
_ Text
out ->
        Text
"No session found matching" Text -> Text -> Bool
`T.isInfixOf` Text
out
          Bool -> Bool -> Bool
|| Text
"Session not found" Text -> Text -> Bool
`T.isInfixOf` Text
out,
      cliScrub :: Text -> Text
cliScrub = Text -> Text
cleanCliOut,
      cliStderr :: StderrPolicy
cliStderr = StderrPolicy
StderrMerge,
      cliStderrTee :: Maybe String
cliStderrTee = Maybe String
forall a. Maybe a
Nothing,
      cliTranscript :: Maybe (IORef Int, String)
cliTranscript = Maybe (IORef Int, String)
mTranscript
    }

-- | Batch variant of 'hermesHost'. Joins all post bodies into a single user
-- message and makes one @hermes chat -q@ call, returning one reply. Use when
-- multiple posts may arrive in a single wake cycle and the agent should see
-- them as a combined conversation turn.
hermesHostBatch ::
  -- | Host name (used as the 'from' field of reply posts).
  Text ->
  -- | System prompt text prepended to every body.
  Text ->
  -- | Model name passed to @hermes -m@, if any.
  Maybe Text ->
  -- | Provider passed to @hermes --provider@, if any.
  Maybe Text ->
  -- | Pass @--yolo -Q@ to hermes.
  Bool ->
  -- | Session file for cross-call context.
  FilePath ->
  -- | Optional transcript sink.
  Maybe (IORef Int, FilePath) ->
  Host
hermesHostBatch :: Text
-> Text
-> Maybe Text
-> Maybe Text
-> Bool
-> String
-> Maybe (IORef Int, String)
-> Host
hermesHostBatch Text
name Text
systemPrompt Maybe Text
model Maybe Text
provider Bool
yolo String
sessionFile Maybe (IORef Int, String)
mTranscript =
  Host
    { hostName :: Text
hostName = Text
name,
      hostBodyMode :: BodyMode
hostBodyMode = BodyMode
BodyWhole,
      hostRun :: [Text] -> IO [Text]
hostRun = \[Text]
bodies -> do
        let userMessage :: Text
userMessage = [Text] -> Text
T.unlines [Text]
bodies
            prompt :: Text
prompt = Text
systemPrompt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\nUser messages:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
userMessage
        rsp <- Cli -> Text -> IO Text
cliQuery Cli
cli Text
prompt
        pure [cleanCliOut rsp]
    }
  where
    cli :: Cli
cli = Maybe Text
-> Maybe Text -> Bool -> String -> Maybe (IORef Int, String) -> Cli
hermesCli Maybe Text
model Maybe Text
provider Bool
yolo String
sessionFile Maybe (IORef Int, String)
mTranscript

-- | Connection configuration for a direct API host.
data BareConfig = BareConfig
  { -- | Identity / from-field for reply posts.
    BareConfig -> Text
agentName :: Text,
    -- | API base URL, e.g. "https://api.deepseek.com/v1".
    BareConfig -> Text
baseUrl :: Text,
    -- | Model name, e.g. "deepseek-v4-pro".
    BareConfig -> Text
model :: Text,
    -- | API key.
    BareConfig -> Text
key :: Text
  }
  deriving (Int -> BareConfig -> ShowS
[BareConfig] -> ShowS
BareConfig -> String
(Int -> BareConfig -> ShowS)
-> (BareConfig -> String)
-> ([BareConfig] -> ShowS)
-> Show BareConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BareConfig -> ShowS
showsPrec :: Int -> BareConfig -> ShowS
$cshow :: BareConfig -> String
show :: BareConfig -> String
$cshowList :: [BareConfig] -> ShowS
showList :: [BareConfig] -> ShowS
Show, BareConfig -> BareConfig -> Bool
(BareConfig -> BareConfig -> Bool)
-> (BareConfig -> BareConfig -> Bool) -> Eq BareConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BareConfig -> BareConfig -> Bool
== :: BareConfig -> BareConfig -> Bool
$c/= :: BareConfig -> BareConfig -> Bool
/= :: BareConfig -> BareConfig -> Bool
Eq)

-- | Sensible defaults for an OpenAI-compatible DeepSeek host.
defaultBareConfig :: BareConfig
defaultBareConfig :: BareConfig
defaultBareConfig =
  BareConfig
    { agentName :: Text
agentName = Text
"agent",
      baseUrl :: Text
baseUrl = Text
"https://api.deepseek.com/v1",
      model :: Text
model = Text
"deepseek-v4-pro",
      key :: Text
key = Text
""
    }

-- | A host backed by a direct OpenAI-compatible chat completions API call.
--
-- The caller supplies the system prompt; the post body becomes the user
-- message. There is no tooling, memory, or context-file injection.
bareHost ::
  -- | Connection configuration.
  BareConfig ->
  -- | System prompt.
  Text ->
  Host
bareHost :: BareConfig -> Text -> Host
bareHost BareConfig
cfg Text
systemPrompt =
  Host
    { hostName :: Text
hostName = BareConfig -> Text
agentName BareConfig
cfg,
      hostBodyMode :: BodyMode
hostBodyMode = BodyMode
BodyWhole,
      hostRun :: [Text] -> IO [Text]
hostRun = \[Text]
bodies -> do
        let userMessage :: Text
userMessage = [Text] -> Text
T.unlines [Text]
bodies
        rsp <- BareConfig -> Text -> Text -> IO Text
chatCompletion BareConfig
cfg Text
systemPrompt Text
userMessage
        pure [rsp]
    }

chatCompletion :: BareConfig -> Text -> Text -> IO Text
chatCompletion :: BareConfig -> Text -> Text -> IO Text
chatCompletion BareConfig
cfg Text
systemPrompt Text
userMessage = do
  manager <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
  initialRequest <- parseRequest (T.unpack (baseUrl cfg <> "/chat/completions"))
  let request =
        Request
initialRequest
          { method = "POST",
            requestHeaders =
              [ ("Content-Type", "application/json"),
                ("Authorization", "Bearer " <> BC8.pack (T.unpack (key cfg)))
              ],
            requestBody =
              RequestBodyLBS $
                BL.fromStrict $
                  encodeJson $
                    JObject
                      [ ("model", JString (model cfg)),
                        ( "messages",
                          JArray
                            ( V.fromList
                                [ JObject [("role", JString "system"), ("content", JString systemPrompt)],
                                  JObject [("role", JString "user"), ("content", JString userMessage)]
                                ]
                            )
                        ),
                        ("max_tokens", JNumber 4096)
                      ]
          }
  response <- httpLbs request manager
  let status = Status -> Int
statusCode (Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
response)
      body = Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
response
  if status < 200 || status >= 300
    then pure ("🔴 HTTP " <> T.pack (show status) <> ": " <> TE.decodeUtf8 (BL.toStrict body))
    else case decodeJson (BL.toStrict body) of
      Left String
err -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"🔴 JSON error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
err)
      Right Json
j -> case Text -> Json -> Maybe Json
jObjLookup Text
"choices" Json
j of
        Just (JArray Vector Json
vs) -> case Vector Json -> [Json]
forall a. Vector a -> [a]
V.toList Vector Json
vs of
          [] -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"🔴 empty choices"
          (Json
c : [Json]
_) -> case Text -> Json -> Maybe Json
jObjLookup Text
"message" Json
c of
            Just Json
m -> case Text -> Json -> Maybe Json
jObjLookup Text
"content" Json
m of
              Just (JString Text
t) -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
t
              Maybe Json
_ -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"🔴 missing content"
            Maybe Json
_ -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"🔴 missing message"
        Maybe Json
_ -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"🔴 empty choices"
  where
    jObjLookup :: Text -> Json -> Maybe Json
    jObjLookup :: Text -> Json -> Maybe Json
jObjLookup Text
k (JObject [(Text, Json)]
ps) = Text -> [(Text, Json)] -> Maybe Json
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
k [(Text, Json)]
ps
    jObjLookup Text
_ Json
_ = Maybe Json
forall a. Maybe a
Nothing