{-# LANGUAGE OverloadedStrings #-}

-- | Live CLI agents as opaque shards.
--
-- A 'Cli' recipe describes how to invoke an external CLI agent (hermes, kimi,
-- grok, or any shell command). 'cliQuery' runs the recipe with session
-- resume / stale fallback; 'cliShard' seats it as a 'Circuit.Agent.Shard'.
module Free.Agent.Cli
  ( -- * Invocation recipe
    Cli (..),
    StderrPolicy (..),
    hermesCli,
    kimiCli,
    grokCli,
    parseSessionId,
    cleanCliOut,

    -- * Query
    cliQuery,
    cliQueryBS,

    -- * Shard adapters
    cliShard,

    -- * Transcript
    TranscriptRecord (..),
    encodeTranscriptLine,

    -- * Generic adapters (re-exported from 'Circuit.Agent.Query')
    queryShard,
    queryShardWith,
    synthShard,
    echoShard,
    runShardIO,
    sessionPrompt,
    replyPosts,
    synthesisPosts,
  )
where

import Circuit.Agent (Post, Shard)
import Circuit.Agent.Query
  ( echoShard,
    queryShard,
    queryShardWith,
    replyPosts,
    runShardIO,
    sessionPrompt,
    synthShard,
    synthesisPosts,
  )
import Control.Concurrent (threadDelay)
import Control.Exception (SomeException, catch, try)
import Control.Monad (void, when)
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BL
import Data.Char (chr, ord)
import Data.Foldable (for_)
import Data.IORef (IORef, readIORef)
import Data.Maybe (listToMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.IO qualified as TIO
import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime)
import GHC.IO.Handle (hGetContents)
import System.Directory (createDirectoryIfMissing, doesFileExist)
import System.Exit (ExitCode (..))
import System.FilePath (takeDirectory, (-<.>))
import System.IO (hClose)
import System.Process
  ( CreateProcess (std_err, std_out),
    StdStream (CreatePipe),
    createProcess,
    proc,
    readCreateProcessWithExitCode,
    waitForProcess,
  )

-- | Invocation recipe for a CLI agent.
--
-- Everything a session needs is plain data; there are no laws here beyond
-- what the CLI itself honours.
data Cli = Cli
  { -- | The executable (e.g. @"hermes"@, @"/bin/sh"@).
    Cli -> String
cliCommand :: FilePath,
    -- | Full argv (excluding the command) for one query, given the prompt
    -- and any stored session id ('Nothing' = fresh session).
    Cli -> Text -> Maybe Text -> [String]
cliArgv :: Text -> Maybe Text -> [String],
    -- | Stdin for the process, from the prompt ('const ""' for argv-only CLIs).
    Cli -> Text -> String
cliStdin :: Text -> String,
    -- | Where the session id is persisted between calls.
    Cli -> String
cliSessionFile :: FilePath,
    -- | Scrape a session id from CLI output.  @const Nothing@ for CLIs
    -- without sessions; no session file is then ever written.
    Cli -> Text -> Maybe Text
cliSessionId :: Text -> Maybe Text,
    -- | Is this (exit code, output) pair a stale-session response?
    Cli -> ExitCode -> Text -> Bool
cliStale :: ExitCode -> Text -> Bool,
    -- | Noise filter applied to output before it becomes a reply body.
    Cli -> Text -> Text
cliScrub :: Text -> Text,
    -- | What to do with the process's stderr channel.
    Cli -> StderrPolicy
cliStderr :: StderrPolicy,
    -- | Optional tee: raw stderr appended to this log file on every call,
    -- regardless of the policy (interiority stays searchable, never
    -- silently dropped).
    Cli -> Maybe String
cliStderrTee :: Maybe FilePath,
    -- | Optional transcript sink: @(post_id_ref, transcript_jsonl_path)@.
    -- The 'IORef' carries the current post id, set externally before each
    -- query.  One JSONL record is appended per invocation; failure to write
    -- is silent (tee failure is never fatal).
    Cli -> Maybe (IORef Int, String)
cliTranscript :: Maybe (IORef Int, FilePath)
  }

-- | stderr routing for a CLI agent's output channels.
--
-- Precedent: @Muster.Connector@ posts @-- stdout --@ \/ @-- stderr --@
-- marked sections; 'StderrMark' is the in-body equivalent.
data StderrPolicy
  = -- | Discard stderr (use with 'cliStderrTee' to keep a log).
    StderrDrop
  | -- | Concatenate stdout and stderr (the historical behaviour).
    StderrMerge
  | -- | Append stderr after a @-- stderr --@ section marker.
    StderrMark
  deriving (StderrPolicy -> StderrPolicy -> Bool
(StderrPolicy -> StderrPolicy -> Bool)
-> (StderrPolicy -> StderrPolicy -> Bool) -> Eq StderrPolicy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StderrPolicy -> StderrPolicy -> Bool
== :: StderrPolicy -> StderrPolicy -> Bool
$c/= :: StderrPolicy -> StderrPolicy -> Bool
/= :: StderrPolicy -> StderrPolicy -> Bool
Eq, Int -> StderrPolicy -> ShowS
[StderrPolicy] -> ShowS
StderrPolicy -> String
(Int -> StderrPolicy -> ShowS)
-> (StderrPolicy -> String)
-> ([StderrPolicy] -> ShowS)
-> Show StderrPolicy
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StderrPolicy -> ShowS
showsPrec :: Int -> StderrPolicy -> ShowS
$cshow :: StderrPolicy -> String
show :: StderrPolicy -> String
$cshowList :: [StderrPolicy] -> ShowS
showList :: [StderrPolicy] -> ShowS
Show)

-- | Recipe for the kimi CLI: @kimi -p \<prompt\> [-m \<model\>] [--provider \<provider\>] [-r \<sid\>]@,
-- text output.  kimi prints a plain-text resume hint line, so scraping and
-- scrubbing are line-oriented — no JSON needed.  Note: kimi exits 0 even
-- when the prompt fails (and @--auto@ cannot combine with @-p@), so stale
-- detection is output-based.
--
-- stderr (thinking / tool progress / notices) is dropped from the reply
-- but teed raw to @\<sessionFile\>.stderr.log@ — interiority stays
-- searchable, never silently dropped.
kimiCli :: Maybe Text -> Maybe Text -> FilePath -> Cli
kimiCli :: Maybe Text -> Maybe Text -> String -> Cli
kimiCli Maybe Text
model Maybe Text
provider String
sessionFile =
  Cli
    { cliCommand :: String
cliCommand = String
"kimi",
      cliArgv :: Text -> Maybe Text -> [String]
cliArgv = \Text
prompt Maybe Text
mSid ->
        [String
"-p", 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
<> [String] -> (Text -> [String]) -> Maybe Text -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
sid -> [String
"-r", 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
kimiSessionId,
      cliStale :: ExitCode -> Text -> Bool
cliStale = \ExitCode
_ Text
out ->
        Text
"Session \"" Text -> Text -> Bool
`T.isInfixOf` Text
out Bool -> Bool -> Bool
&& Text
"not found" Text -> Text -> Bool
`T.isInfixOf` Text
out,
      cliScrub :: Text -> Text
cliScrub = Text -> Text
kimiText,
      cliStderr :: StderrPolicy
cliStderr = StderrPolicy
StderrDrop,
      -- Interiority log: NAME.sid -> NAME.stderr.log
      cliStderrTee :: Maybe String
cliStderrTee = String -> Maybe String
forall a. a -> Maybe a
Just (String
sessionFile String -> ShowS
-<.> String
"stderr.log"),
      cliTranscript :: Maybe (IORef Int, String)
cliTranscript = Maybe (IORef Int, String)
forall a. Maybe a
Nothing
    }

-- | Scrape the @To resume this session: kimi -r \<id\>@ hint line.
kimiSessionId :: Text -> Maybe Text
kimiSessionId :: Text -> Maybe Text
kimiSessionId Text
out =
  case (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text
"To resume this session:" Text -> Text -> Bool
`T.isPrefixOf`) (Text -> [Text]
T.lines Text
out) of
    (Text
l : [Text]
_) -> [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe ([Text] -> [Text]
forall a. [a] -> [a]
reverse (Text -> [Text]
T.words Text
l))
    [] -> Maybe Text
forall a. Maybe a
Nothing

-- | Drop the resume-hint line; keep the reply text.
kimiText :: Text -> Text
kimiText :: Text -> Text
kimiText =
  Text -> Text
T.strip
    (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines
    ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"To resume this session:" Text -> Text -> Bool
`T.isPrefixOf`))
    ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines

-- | Recipe for the grok CLI: @grok -p \<prompt\> --output-format json
-- [--resume \<sid\>]@.  Plain output carries no session id, so the JSON
-- format is used and the @text\/@sessionId@ fields are extracted.
grokCli :: Maybe Text -> FilePath -> Cli
grokCli :: Maybe Text -> String -> Cli
grokCli Maybe Text
model String
sessionFile =
  Cli
    { cliCommand :: String
cliCommand = String
"grok",
      cliArgv :: Text -> Maybe Text -> [String]
cliArgv = \Text
prompt Maybe Text
mSid ->
        [String
"-p", Text -> String
T.unpack Text
prompt, String
"--output-format", String
"json"]
          [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
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 -> Text -> Maybe Text
jsonField Text
"sessionId",
      cliStale :: ExitCode -> Text -> Bool
cliStale = \ExitCode
code Text
out ->
        ExitCode
code ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess Bool -> Bool -> Bool
|| Text
"Failed to restore session" Text -> Text -> Bool
`T.isInfixOf` Text
out,
      cliScrub :: Text -> Text
cliScrub = Text -> Text
grokText,
      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)
forall a. Maybe a
Nothing
    }

-- | Reply text is the JSON @text@ field, unescaped; if there is no such
-- field (an error page), keep the whole output so failures stay visible.
grokText :: Text -> Text
grokText :: Text -> Text
grokText Text
out = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Text
T.strip Text
out) Text -> Text
unescapeJson (Text -> Text -> Maybe Text
jsonField Text
"text" Text
out)

-- | Best-effort extraction of a top-level @"key": "value"@ string field
-- (space after the colon optional; escapes respected).  Not a JSON parser —
-- good enough for one-line NDJSON records and flat pretty-printed objects.
jsonField :: Text -> Text -> Maybe Text
jsonField :: Text -> Text -> Maybe Text
jsonField Text
key Text
src =
  case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
pat Text
src of
    (Text
_, Text
rest)
      | Text -> Bool
T.null Text
rest -> Maybe Text
forall a. Maybe a
Nothing
      | Bool
otherwise -> Text -> Maybe Text
jsonString ((Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') (Int -> Text -> Text
T.drop (Text -> Int
T.length Text
pat) Text
rest))
  where
    pat :: Text
pat = Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\":"

-- | Read a JSON string body after the opening quote, honouring backslash
-- escapes; 'Nothing' if the opening quote is missing or the string is
-- unterminated.
jsonString :: Text -> Maybe Text
jsonString :: Text -> Maybe Text
jsonString Text
t0 = case Text -> Maybe (Char, Text)
T.uncons Text
t0 of
  Just (Char
'"', Text
t) -> Text -> String -> Maybe Text
go Text
t []
  Maybe (Char, Text)
_ -> Maybe Text
forall a. Maybe a
Nothing
  where
    go :: Text -> String -> Maybe Text
go Text
rest String
acc = case Text -> Maybe (Char, Text)
T.uncons Text
rest of
      Maybe (Char, Text)
Nothing -> Maybe Text
forall a. Maybe a
Nothing
      Just (Char
'\\', Text
r) -> case Text -> Maybe (Char, Text)
T.uncons Text
r of
        Just (Char
c, Text
r') -> Text -> String -> Maybe Text
go Text
r' (Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'\\' Char -> ShowS
forall a. a -> [a] -> [a]
: String
acc)
        Maybe (Char, Text)
Nothing -> Maybe Text
forall a. Maybe a
Nothing
      Just (Char
'"', Text
_) -> Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
T.pack (ShowS
forall a. [a] -> [a]
reverse String
acc))
      Just (Char
c, Text
r') -> Text -> String -> Maybe Text
go Text
r' (Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
acc)

-- | Unescape the common JSON string escapes; unknown escapes are kept
-- literally.  Best-effort, not a full @\\u@ decoder.
unescapeJson :: Text -> Text
unescapeJson :: Text -> Text
unescapeJson Text
t = case Text -> Maybe (Char, Text)
T.uncons Text
t of
  Maybe (Char, Text)
Nothing -> Text
t
  Just (Char
'\\', Text
r) -> case Text -> Maybe (Char, Text)
T.uncons Text
r of
    Just (Char
c, Text
r') -> case Char -> Maybe Char
esc Char
c of
      Just Char
u -> Char -> Text -> Text
T.cons Char
u (Text -> Text
unescapeJson Text
r')
      Maybe Char
Nothing -> Char -> Text -> Text
T.cons Char
'\\' (Char -> Text -> Text
T.cons Char
c (Text -> Text
unescapeJson Text
r'))
    Maybe (Char, Text)
Nothing -> Text
"\\"
  Just (Char
c, Text
r) -> Char -> Text -> Text
T.cons Char
c (Text -> Text
unescapeJson Text
r)
  where
    esc :: Char -> Maybe Char
esc Char
'n' = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'\n'
    esc Char
'r' = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'\r'
    esc Char
't' = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'\t'
    esc Char
'"' = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'"'
    esc Char
'\\' = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'\\'
    esc Char
'/' = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'/'
    esc Char
_ = Maybe Char
forall a. Maybe a
Nothing

-- | Scrape a @session_id:@ line from CLI output.
parseSessionId :: Text -> Maybe Text
parseSessionId :: Text -> Maybe Text
parseSessionId Text
out =
  case (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text
"session_id:" Text -> Text -> Bool
`T.isPrefixOf`) (Text -> [Text]
T.lines Text
out) of
    (Text
line : [Text]
_) ->
      let sid :: Text
sid = Text -> Text
T.strip (Int -> Text -> Text
T.drop (Text -> Int
T.length Text
"session_id:") Text
line)
       in if Text -> Bool
T.null Text
sid then Maybe Text
forall a. Maybe a
Nothing else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
sid
    [] -> Maybe Text
forall a. Maybe a
Nothing

-- | Recipe for the hermes CLI: @hermes chat -q \<prompt\> … --resume \<sid\>@.
hermesCli :: Maybe Text -> Maybe Text -> FilePath -> Cli
hermesCli :: Maybe Text -> Maybe Text -> String -> Cli
hermesCli Maybe Text
model Maybe Text
provider String
sessionFile =
  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
<> [String
"--yolo", String
"-Q", String
"--max-turns", String
"90"]
          [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
_code 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)
forall a. Maybe a
Nothing
    }

-- | Maximum retries for transient failures when resuming a session.
-- A transient failure (non-zero exit, not stale) is retried with the
-- same session id before giving up.
cliMaxRetries :: Int
cliMaxRetries :: Int
cliMaxRetries = Int
3

-- | One query against a CLI agent.
-- First call (or no stored session) runs fresh; subsequent calls resume the
-- stored session id.  A stale session falls back to fresh and records the
-- new id.  Scraped ids are re-persisted on every successful call, so
-- server-side session rotation is followed.
cliQuery :: Cli -> Text -> IO Text
cliQuery :: Cli -> Text -> IO Text
cliQuery Cli
cli Text
prompt = do
  t0 <- IO UTCTime
getCurrentTime
  mSid <- readStoredSession (cliSessionFile cli)
  case mSid of
    Maybe Text
Nothing -> UTCTime -> IO Text
fresh UTCTime
t0
    Just Text
sid -> do
      (code, raw, routedOut, elapsed) <- UTCTime -> Maybe Text -> IO (ExitCode, Text, Text, Int)
run UTCTime
t0 (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
sid)
      if cliStale cli code raw
        then fresh t0
        else
          if code /= ExitSuccess
            then retryWithSession t0 sid 1
            else do
              let mSid' = Cli -> Text -> Maybe Text
cliSessionId Cli
cli Text
raw
              for_ mSid' (writeStoredSession (cliSessionFile cli))
              writeTranscript t0 code raw elapsed mSid'
              pure (cliScrub cli routedOut)
  where
    -- Retry a transient failure with the same session id.  After
    -- 'cliMaxRetries' attempts without success the error is propagated
    -- upward to the seat loop (which posts 🔴 to pitboss).
    retryWithSession :: UTCTime -> Text -> Int -> IO Text
retryWithSession UTCTime
t0' Text
sid Int
attempt
      | Int
attempt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
cliMaxRetries =
          String -> IO Text
forall a. HasCallStack => String -> IO a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail
            ( String
"cliQuery: "
                String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Cli -> String
cliCommand Cli
cli
                String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" exited non-zero "
                String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
cliMaxRetries
                String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" times; last attempt with session "
                String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (Int -> Text -> Text
T.take Int
20 Text
sid)
            )
      | Bool
otherwise = do
          -- Linear back-off: 100ms * attempt.
          Int -> IO ()
threadDelay (Int
100000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
attempt)
          (code', raw', routedOut', elapsed') <- UTCTime -> Maybe Text -> IO (ExitCode, Text, Text, Int)
run UTCTime
t0' (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
sid)
          if cliStale cli code' raw'
            then fresh t0'
            else
              if code' /= ExitSuccess
                then retryWithSession t0' sid (attempt + 1)
                else do
                  let mSid' = Cli -> Text -> Maybe Text
cliSessionId Cli
cli Text
raw'
                  for_ mSid' (writeStoredSession (cliSessionFile cli))
                  writeTranscript t0' code' raw' elapsed' mSid'
                  pure (cliScrub cli routedOut')
    -- (exit code, raw merged out<>err pre-policy, policy-routed output, elapsed ms).
    -- cliStale and scrape act on the raw merged stream: stale notices and
    -- resume hints live on stderr for some CLIs, and 'StderrDrop' must not
    -- hide them — it only filters the reply body.
    run :: UTCTime -> Maybe Text -> IO (ExitCode, Text, Text, Int)
run UTCTime
t0' Maybe Text
mSid = do
      (code, out, err) <-
        CreateProcess -> String -> IO (ExitCode, String, String)
readCreateProcessWithExitCode
          (String -> [String] -> CreateProcess
proc (Cli -> String
cliCommand Cli
cli) (Cli -> Text -> Maybe Text -> [String]
cliArgv Cli
cli Text
prompt Maybe Text
mSid))
          (Cli -> Text -> String
cliStdin Cli
cli Text
prompt)
      t1 <- getCurrentTime
      let elapsed = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
t1 UTCTime
t0') Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
1000 :: Double))
      tee err
      pure (code, T.pack out <> T.pack err, T.pack out <> routed (T.pack err), elapsed)
    tee :: String -> IO ()
tee String
err =
      Maybe String -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Cli -> Maybe String
cliStderrTee Cli
cli) ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
path -> do
        Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (ShowS
takeDirectory String
path)
        String -> Text -> IO ()
TIO.appendFile String
path (String -> Text
T.pack String
err)
    routed :: Text -> Text
routed Text
err = case Cli -> StderrPolicy
cliStderr Cli
cli of
      StderrPolicy
StderrDrop -> Text
""
      StderrPolicy
StderrMerge -> Text
err
      StderrPolicy
StderrMark
        | Text -> Bool
T.null (Text -> Text
T.strip Text
err) -> Text
""
        | Bool
otherwise -> Text
"\n-- stderr --\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
    fresh :: UTCTime -> IO Text
fresh UTCTime
t0' = do
      (code, raw, routedOut, elapsed) <- UTCTime -> Maybe Text -> IO (ExitCode, Text, Text, Int)
run UTCTime
t0' Maybe Text
forall a. Maybe a
Nothing
      when (code /= ExitSuccess) $
        fail
          ( "cliQuery: "
              <> cliCommand cli
              <> " exited "
              <> show code
              <> ": "
              <> T.unpack (T.take 200 raw)
          )
      let mSid' = Cli -> Text -> Maybe Text
cliSessionId Cli
cli Text
raw
      for_ mSid' (writeStoredSession (cliSessionFile cli))
      writeTranscript t0' code raw elapsed mSid'
      pure (cliScrub cli routedOut)
    writeTranscript :: UTCTime -> ExitCode -> Text -> Int -> Maybe Text -> IO ()
writeTranscript UTCTime
t0' ExitCode
code Text
raw Int
elapsed Maybe Text
mSid' =
      Maybe (IORef Int, String)
-> ((IORef Int, String) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Cli -> Maybe (IORef Int, String)
cliTranscript Cli
cli) (((IORef Int, String) -> IO ()) -> IO ())
-> ((IORef Int, String) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(IORef Int
ref, String
path) -> do
        pid <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
ref
        let rec =
              TranscriptRecord
                { trPostId :: Int
trPostId = Int
pid,
                  trTimestamp :: UTCTime
trTimestamp = UTCTime
t0',
                  trExitCode :: Int
trExitCode = case ExitCode
code of
                    ExitCode
ExitSuccess -> Int
0
                    ExitFailure Int
n -> Int
n,
                  trElapsedMs :: Int
trElapsedMs = Int
elapsed,
                  trSessionId :: Maybe Text
trSessionId = Maybe Text
mSid',
                  trRaw :: Text
trRaw = Text
raw
                }
            line = TranscriptRecord -> Text
encodeTranscriptLine TranscriptRecord
rec Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
        catch
          ( do
              createDirectoryIfMissing True (takeDirectory path)
              TIO.appendFile path line
          )
          (\(SomeException
_ :: SomeException) -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | Like 'cliQuery' but returns raw stdout as 'BS.ByteString' before
-- any decoding or filtering.  Uses 'CreatePipe' to read bytes directly
-- from the process rather than going through the locale-aware 'String'
-- path of 'readCreateProcessWithExitCode'.
cliQueryBS :: Cli -> Text -> IO BS.ByteString
cliQueryBS :: Cli -> Text -> IO ByteString
cliQueryBS Cli
cli Text
prompt = do
  let cp :: CreateProcess
cp =
        (String -> [String] -> CreateProcess
proc (Cli -> String
cliCommand Cli
cli) (Cli -> Text -> Maybe Text -> [String]
cliArgv Cli
cli Text
prompt Maybe Text
forall a. Maybe a
Nothing))
          { std_out = CreatePipe,
            std_err = CreatePipe
          }
  (_, Just outH, Just errH, ph) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
cp
  -- Read the error handle fully so the process doesn't block.
  _ <- BS.hGetContents errH
  raw <- BS.hGetContents outH
  code <- waitForProcess ph
  hClose errH
  hClose outH
  if code /= ExitSuccess
    then fail ("cliQueryBS: " <> cliCommand cli <> " exited " <> show code)
    else pure raw

readStoredSession :: FilePath -> IO (Maybe Text)
readStoredSession :: String -> IO (Maybe Text)
readStoredSession String
path = do
  exists <- String -> IO Bool
doesFileExist String
path
  if not exists
    then pure Nothing
    else do
      res <- try @SomeException (TIO.readFile path)
      pure $ case res of
        Left SomeException
_ -> Maybe Text
forall a. Maybe a
Nothing
        Right Text
t ->
          let sid :: Text
sid = Text -> Text
T.strip Text
t
           in if Text -> Bool
T.null Text
sid then Maybe Text
forall a. Maybe a
Nothing else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
sid

writeStoredSession :: FilePath -> Text -> IO ()
writeStoredSession :: String -> Text -> IO ()
writeStoredSession String
path Text
sid = do
  Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (ShowS
takeDirectory String
path)
  String -> Text -> IO ()
TIO.writeFile String
path Text
sid

-- | Hermes-flavoured TUI noise filter: drops session chatter, decorative
-- rules, and ANSI lines; keeps plain reply text with no trailing newline.
cleanCliOut :: Text -> Text
cleanCliOut :: Text -> Text
cleanCliOut =
  Text -> Text
T.strip
    (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines
    ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter Text -> Bool
keep
    ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.strip
    ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines
  where
    keep :: Text -> Bool
keep Text
l
      | Text -> Bool
T.null Text
l = Bool
False
      | Text
"(empty)" Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
l = Bool
False
      | Text
"session_id:" Text -> Text -> Bool
`T.isPrefixOf` Text
l = Bool
False
      | Text
"Warning:" Text -> Text -> Bool
`T.isPrefixOf` Text
l = Bool
False
      | Text
"Resumed session" Text -> Text -> Bool
`T.isInfixOf` Text
l = Bool
False
      | Text
"Reached maximum" Text -> Text -> Bool
`T.isInfixOf` Text
l = Bool
False
      | Text
"Requesting summary" Text -> Text -> Bool
`T.isInfixOf` Text
l = Bool
False
      | Text
"No session found matching" Text -> Text -> Bool
`T.isInfixOf` Text
l = Bool
False
      | Text
"Use 'hermes sessions list'" Text -> Text -> Bool
`T.isInfixOf` Text
l = Bool
False
      | Text
"Resume this session with:" Text -> Text -> Bool
`T.isInfixOf` Text
l = Bool
False
      | Text
"Shutting down" Text -> Text -> Bool
`T.isInfixOf` Text
l = Bool
False
      | Text
"Session:" Text -> Text -> Bool
`T.isPrefixOf` Text
l = Bool
False
      | Text
"Duration:" Text -> Text -> Bool
`T.isPrefixOf` Text
l = Bool
False
      | Text
"Messages:" Text -> Text -> Bool
`T.isPrefixOf` Text
l = Bool
False
      | Text
"⚕" Text -> Text -> Bool
`T.isPrefixOf` Text
l = Bool
False
      | Text
"❯" Text -> Text -> Bool
`T.isPrefixOf` Text
l = Bool
False
      | Text
"Query:" Text -> Text -> Bool
`T.isPrefixOf` Text
l = Bool
False
      | Text
"Initializing agent" Text -> Text -> Bool
`T.isInfixOf` Text
l = Bool
False
      | Text
"┊" Text -> Text -> Bool
`T.isPrefixOf` Text
l = Bool
False
      | Text
"hermes --resume" Text -> Text -> Bool
`T.isInfixOf` Text
l = Bool
False
      | Text
"hermes chat" Text -> Text -> Bool
`T.isInfixOf` Text
l = Bool
False
      | (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\x1b') Text
l = Bool
False
      | Text -> Bool
isDecorative Text
l = Bool
False
      | Bool
otherwise = Bool
True
    isDecorative :: Text -> Bool
isDecorative Text
t =
      (Char -> Bool) -> Text -> Bool
T.all
        ( \Char
c ->
            Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' '
              Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r'
              Bool -> Bool -> Bool
|| Char
c
                Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"─│┌┐└┘╭╮╰╯" :: String)
        )
        Text
t

-- | One transcript record, as JSONL appended to the transcript log.
data TranscriptRecord = TranscriptRecord
  { TranscriptRecord -> Int
trPostId :: Int,
    TranscriptRecord -> UTCTime
trTimestamp :: UTCTime,
    TranscriptRecord -> Int
trExitCode :: Int,
    TranscriptRecord -> Int
trElapsedMs :: Int,
    TranscriptRecord -> Maybe Text
trSessionId :: Maybe Text,
    TranscriptRecord -> Text
trRaw :: Text
  }

-- | Encode a transcript record as a single JSON line (no trailing newline).
encodeTranscriptLine :: TranscriptRecord -> Text
encodeTranscriptLine :: TranscriptRecord -> Text
encodeTranscriptLine TranscriptRecord
r =
  Text
"{"
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a -> a
kv Text
"post_id" (String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show (TranscriptRecord -> Int
trPostId TranscriptRecord
r)))
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
","
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a -> a
kv Text
"ts" (Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
escapeText (String -> Text
T.pack (UTCTime -> String
forall a. Show a => a -> String
show (TranscriptRecord -> UTCTime
trTimestamp TranscriptRecord
r))) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\"")
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
","
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a -> a
kv Text
"exit_code" (String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show (TranscriptRecord -> Int
trExitCode TranscriptRecord
r)))
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
","
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a -> a
kv Text
"elapsed_ms" (String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show (TranscriptRecord -> Int
trElapsedMs TranscriptRecord
r)))
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
","
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a -> a
kv Text
"session_id" (Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"null" (\Text
t -> Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
escapeText Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\"") (TranscriptRecord -> Maybe Text
trSessionId TranscriptRecord
r))
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
","
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a -> a
kv Text
"raw" (Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
escapeText (TranscriptRecord -> Text
trRaw TranscriptRecord
r) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\"")
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}"
  where
    kv :: a -> a -> a
kv a
k a
v = a
"\"" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
k a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"\":" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
v

-- | Minimal JSON string escaping: backslash, double-quote, control chars.
escapeText :: Text -> Text
escapeText :: Text -> Text
escapeText = (Char -> Text) -> Text -> Text
T.concatMap Char -> Text
escChar
  where
    escChar :: Char -> Text
escChar Char
c
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\' = Text
"\\\\"
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\"' = Text
"\\\""
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' = Text
"\\n"
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r' = Text
"\\r"
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t' = Text
"\\t"
      | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
'\x20' = Text
"\\u" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> Text -> Text
T.justifyRight Int
4 Char
'0' (String -> Text
T.pack (Int -> ShowS
showHex (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c) String
""))
      | Bool
otherwise = Char -> Text
T.singleton Char
c
    showHex :: Int -> ShowS
showHex Int
n String
s = case Int
n Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
16 of
      (Int
0, Int
d) -> Int -> Char
hexDigit Int
d Char -> ShowS
forall a. a -> [a] -> [a]
: String
s
      (Int
q, Int
d) -> Int -> ShowS
showHex Int
q (Int -> Char
hexDigit Int
d Char -> ShowS
forall a. a -> [a] -> [a]
: String
s)
    hexDigit :: Int -> Char
hexDigit Int
d
      | Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10 = Int -> Char
chr (Char -> Int
ord Char
'0' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d)
      | Bool
otherwise = Int -> Char
chr (Char -> Int
ord Char
'a' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
10)

-- | A live CLI agent as a list 'Shard'.  Session file and process stay
-- inside @IO@ — apply-only at this boundary.  @who@ is the agent nick
-- (from on emitted posts).
cliShard :: Text -> Cli -> IO (Shard IO [Post Text] [Post Text])
cliShard :: Text -> Cli -> IO (Shard IO [Post Text] [Post Text])
cliShard Text
who Cli
cli = Text -> (Text -> IO Text) -> IO (Shard IO [Post Text] [Post Text])
queryShard Text
who (Cli -> Text -> IO Text
cliQuery Cli
cli)