{-# LANGUAGE OverloadedStrings #-}

-- | ACP (Agent Client Protocol) JSON-RPC 2.0 NDJSON client over
-- 'Circuit.Agent.Process' ends.
--
-- The wire: one JSON object per line on the child's stdout (no
-- Content-Length headers); stdin takes the same framing; stderr is
-- diagnostics, not protocol.  Requests are id-correlated; notifications
-- carry no id; kimi also issues reverse-RPC requests (with an id) that the
-- client must answer.
--
-- Ground truth is the leg-1 probe (@~\/lab\/acp-probe\/report.md@,
-- kimi acp v0.33.0):
--
--   * @session\/set_mode@ hangs — mode is switched with
--     @session\/set_config_option {configId: "mode", value: "auto"}@.
--   * @session\/request_permission@ responses are broken in kimi 0.33.0;
--     in @auto@ mode file I\/O arrives as @fs\/*@ reverse-RPCs instead.
--   * @fs\/*@ params carry @uri@ (with a @file:\/\/\/\/@ prefix), not the
--     spec's @path@ — both are accepted here.
--
-- Requests travel through the shared stdin 'commit' port of
-- 'Circuit.Agent.StdPorts'; replies are line-framed blocking reads from the
-- stdout queue.
module Free.Agent.Acp
  ( -- * Configuration
    AcpConfig (..),
    defaultAcpConfig,

    -- * Client
    AcpClient (..),
    openAcp,
    closeAcp,

    -- * Wire frames
    Frame (..),
    classifyFrame,

    -- * Session updates
    Update (..),
    parseUpdate,

    -- * Requests
    acpSendValue,
    acpReadFrame,
    acpRequest,
    acpInitialize,
    acpNewSession,
    acpSetConfigOption,
    acpSetModeAuto,
    acpPrompt,
    PromptResult (..),
    acpCancel,
    acpReadStderr,
  )
where

import Circuit.Agent.StdPorts
  ( ProcConfig (..),
    StdPorts (..),
    defaultProcConfig,
    lineMarks,
    openStdPorts,
  )
import Circuit.Category (K (..))
import Circuit.Layer (run)
import Circuit.Parser.Json (Json (..), decodeJson)
import Circuit.Poles (HasDual (..), In (..), Out (..), Poles (..))
import Circuit.Syntax (eval)
import Control.Exception (SomeException, try)
import Control.Monad (forM_)
import Data.Foldable (foldr)
import Data.IORef (IORef, atomicModifyIORef', newIORef)
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import Data.Scientific (toBoundedInteger)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Text.IO qualified as TIO
import Data.Time (diffUTCTime, getCurrentTime)
import Free.Agent.Json
import System.Directory (createDirectoryIfMissing)
import System.FilePath (takeDirectory)
import System.Timeout (timeout)
import Prelude

-- ---------------------------------------------------------------------------
-- Configuration
-- ---------------------------------------------------------------------------

-- | What to spawn and where the plumbing lives.
data AcpConfig = AcpConfig
  { -- | The executable (default @"kimi"@).
    AcpConfig -> FilePath
acpCommand :: FilePath,
    -- | argv (default @["acp"]@).
    AcpConfig -> [FilePath]
acpArgs :: [String],
    -- | The child's working directory.  The ACP session cwd is pinned
    -- separately via @session/new@.
    AcpConfig -> FilePath
acpWorkDir :: FilePath,
    -- | Optional raw-frame transcript (NDJSON, one @{ts,dir,raw}@ per line,
    -- @dir@ ∈ send\/recv), mirroring the python probe's transcript.
    AcpConfig -> Maybe FilePath
acpTranscript :: Maybe FilePath
  }
  deriving (Int -> AcpConfig -> ShowS
[AcpConfig] -> ShowS
AcpConfig -> FilePath
(Int -> AcpConfig -> ShowS)
-> (AcpConfig -> FilePath)
-> ([AcpConfig] -> ShowS)
-> Show AcpConfig
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AcpConfig -> ShowS
showsPrec :: Int -> AcpConfig -> ShowS
$cshow :: AcpConfig -> FilePath
show :: AcpConfig -> FilePath
$cshowList :: [AcpConfig] -> ShowS
showList :: [AcpConfig] -> ShowS
Show, AcpConfig -> AcpConfig -> Bool
(AcpConfig -> AcpConfig -> Bool)
-> (AcpConfig -> AcpConfig -> Bool) -> Eq AcpConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AcpConfig -> AcpConfig -> Bool
== :: AcpConfig -> AcpConfig -> Bool
$c/= :: AcpConfig -> AcpConfig -> Bool
/= :: AcpConfig -> AcpConfig -> Bool
Eq)

-- | @kimi acp@ with the child working directory at @\/tmp\/free-agent-acp@.
defaultAcpConfig :: AcpConfig
defaultAcpConfig :: AcpConfig
defaultAcpConfig =
  AcpConfig
    { acpCommand :: FilePath
acpCommand = FilePath
"kimi",
      acpArgs :: [FilePath]
acpArgs = [FilePath
"acp"],
      acpWorkDir :: FilePath
acpWorkDir = FilePath
"/tmp/free-agent-acp",
      acpTranscript :: Maybe FilePath
acpTranscript = Maybe FilePath
forall a. Maybe a
Nothing
    }

-- ---------------------------------------------------------------------------
-- Client
-- ---------------------------------------------------------------------------

-- | A live ACP child process plus client-side protocol state.
data AcpClient = AcpClient
  { AcpClient -> StdPorts Text Text Text
acpPorts :: StdPorts Text Text Text,
    AcpClient -> AcpConfig
acpConfig :: AcpConfig,
    -- | Next JSON-RPC request id (monotonic from 1).
    AcpClient -> IORef Int
acpNextId :: IORef Int
  }

-- | Spawn the ACP child and open the protocol state.  Pipes all the way
-- down: no FIFO, no log files — stdout frames arrive line by line on the
-- blocking emit end.
openAcp :: AcpConfig -> IO AcpClient
openAcp :: AcpConfig -> IO AcpClient
openAcp AcpConfig
cfg = do
  let wd :: FilePath
wd = AcpConfig -> FilePath
acpWorkDir AcpConfig
cfg
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
wd
  let replCfg :: ProcConfig
replCfg =
        ProcConfig
defaultProcConfig
          { procCommand = acpCommand cfg,
            procArgs = acpArgs cfg,
            procWorkingDir = wd,
            procMarks = lineMarks
          }
  pp <- K IO () (StdPorts Text Text Text)
-> () -> IO (StdPorts Text Text Text)
forall {k} (m :: k -> *) a (b :: k). K m a b -> a -> m b
runK (Syntax
  (SigCompose :+: SigYank Either) (K IO) () (StdPorts Text Text Text)
-> K IO () (StdPorts Text Text Text)
forall (arr :: * -> * -> *) (sig :: Sig) a b.
(Category arr, Algebra sig arr arr, Ctx sig arr arr) =>
Syntax sig arr a b -> arr a b
eval ((Text -> ByteString)
-> (ByteString -> Text)
-> ProcConfig
-> Syntax
     (SigCompose :+: SigYank Either) (K IO) () (StdPorts Text Text Text)
forall a.
(a -> ByteString)
-> (ByteString -> a)
-> ProcConfig
-> Trace Either (K IO) () (StdPorts a a a)
openStdPorts Text -> ByteString
encodeUtf8 ByteString -> Text
decodeUtf8 ProcConfig
replCfg)) ()
  nref <- newIORef 1
  pure
    AcpClient
      { acpPorts = pp,
        acpConfig = cfg,
        acpNextId = nref
      }

-- | Terminate the child (kills the pumps, closes the pipes).
closeAcp :: AcpClient -> IO ()
closeAcp :: AcpClient -> IO ()
closeAcp AcpClient
c = StdPorts Text Text Text -> IO ()
forall a b c. StdPorts a b c -> IO ()
stdClose (AcpClient -> StdPorts Text Text Text
acpPorts AcpClient
c)

-- ---------------------------------------------------------------------------
-- Transcript
-- ---------------------------------------------------------------------------

logFrame :: AcpClient -> Text -> Text -> IO ()
logFrame :: AcpClient -> Text -> Text -> IO ()
logFrame AcpClient
c Text
dir Text
raw =
  Maybe FilePath -> (FilePath -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (AcpConfig -> Maybe FilePath
acpTranscript (AcpClient -> AcpConfig
acpConfig AcpClient
c)) ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
fp -> do
    now <- IO UTCTime
getCurrentTime
    let line = Json -> Text
encodeJsonText ([(Text, Json)] -> Json
jobject [(Text
"ts", Text -> Json
jtext (FilePath -> Text
T.pack (UTCTime -> FilePath
forall a. Show a => a -> FilePath
show UTCTime
now))), (Text
"dir", Text -> Json
jtext Text
dir), (Text
"raw", Text -> Json
jtext Text
raw)])
    TIO.appendFile fp (line <> "\n")

-- ---------------------------------------------------------------------------
-- JSON plumbing
-- ---------------------------------------------------------------------------

resultOf :: Json -> Maybe Json
resultOf :: Json -> Maybe Json
resultOf = Text -> Json -> Maybe Json
objLookup Text
"result"

jsonToInt :: Json -> Maybe Int
jsonToInt :: Json -> Maybe Int
jsonToInt (JNumber Scientific
n) = Scientific -> Maybe Int
forall i. (Integral i, Bounded i) => Scientific -> Maybe i
toBoundedInteger Scientific
n
jsonToInt Json
_ = Maybe Int
forall a. Maybe a
Nothing

-- | A classified incoming frame.
data Frame
  = -- | Response to one of our requests: id and the whole message
    -- (@result@ or @error@ lives inside).
    Response Int Json
  | -- | Reverse-RPC: kimi requests something from the client.
    AgentRequest Int Text Json
  | -- | Notification (no id): method and params.
    Notification Text Json
  deriving (Int -> Frame -> ShowS
[Frame] -> ShowS
Frame -> FilePath
(Int -> Frame -> ShowS)
-> (Frame -> FilePath) -> ([Frame] -> ShowS) -> Show Frame
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Frame -> ShowS
showsPrec :: Int -> Frame -> ShowS
$cshow :: Frame -> FilePath
show :: Frame -> FilePath
$cshowList :: [Frame] -> ShowS
showList :: [Frame] -> ShowS
Show)

-- | Classify a decoded message.  Note ids are 'Int's and may be 0 (kimi
-- sends @id: 0@ on @session\/request_permission@).
classifyFrame :: Json -> Maybe Frame
classifyFrame :: Json -> Maybe Frame
classifyFrame Json
j = case (Text -> Json -> Maybe Json
objLookup Text
"id" Json
j, Text -> Json -> Maybe Json
objLookup Text
"method" Json
j) of
  (Just Json
idV, Just (JString Text
m))
    | Just Int
i <- Json -> Maybe Int
jsonToInt Json
idV ->
        Frame -> Maybe Frame
forall a. a -> Maybe a
Just (Int -> Text -> Json -> Frame
AgentRequest Int
i Text
m (Json -> Maybe Json -> Json
forall a. a -> Maybe a -> a
fromMaybe Json
JNull (Text -> Json -> Maybe Json
objLookup Text
"params" Json
j)))
  (Just Json
idV, Maybe Json
_)
    | Just Int
i <- Json -> Maybe Int
jsonToInt Json
idV -> Frame -> Maybe Frame
forall a. a -> Maybe a
Just (Int -> Json -> Frame
Response Int
i Json
j)
  (Maybe Json
_, Just (JString Text
m)) ->
    Frame -> Maybe Frame
forall a. a -> Maybe a
Just (Text -> Json -> Frame
Notification Text
m (Json -> Maybe Json -> Json
forall a. a -> Maybe a -> a
fromMaybe Json
JNull (Text -> Json -> Maybe Json
objLookup Text
"params" Json
j)))
  (Maybe Json, Maybe Json)
_ -> Maybe Frame
forall a. Maybe a
Nothing

-- ---------------------------------------------------------------------------
-- Session updates
-- ---------------------------------------------------------------------------

-- | Parsed @session\/update@ notification payload (@params.update@).
data Update
  = AgentMessageChunk Text
  | AgentThoughtChunk Text
  | ToolCall Json
  | ToolCallUpdate Json
  | AvailableCommandsUpdate Json
  | SessionInfoUpdate Json
  | UsageUpdate Json
  | UnknownUpdate Text Json
  deriving (Update -> Update -> Bool
(Update -> Update -> Bool)
-> (Update -> Update -> Bool) -> Eq Update
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Update -> Update -> Bool
== :: Update -> Update -> Bool
$c/= :: Update -> Update -> Bool
/= :: Update -> Update -> Bool
Eq, Int -> Update -> ShowS
[Update] -> ShowS
Update -> FilePath
(Int -> Update -> ShowS)
-> (Update -> FilePath) -> ([Update] -> ShowS) -> Show Update
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Update -> ShowS
showsPrec :: Int -> Update -> ShowS
$cshow :: Update -> FilePath
show :: Update -> FilePath
$cshowList :: [Update] -> ShowS
showList :: [Update] -> ShowS
Show)

-- | Parse the @params@ of a @session\/update@ notification.  'Nothing' if
-- the @update@ object or its @sessionUpdate@ tag is missing.
parseUpdate :: Json -> Maybe Update
parseUpdate :: Json -> Maybe Update
parseUpdate Json
params = do
  upd <- Text -> Json -> Maybe Json
objLookup Text
"update" Json
params
  tag <- textAt "sessionUpdate" upd
  pure $ case tag of
    Text
"agent_message_chunk" -> Text -> Update
AgentMessageChunk (Json -> Text
contentText Json
upd)
    Text
"agent_thought_chunk" -> Text -> Update
AgentThoughtChunk (Json -> Text
contentText Json
upd)
    Text
"tool_call" -> Json -> Update
ToolCall Json
upd
    Text
"tool_call_update" -> Json -> Update
ToolCallUpdate Json
upd
    Text
"available_commands_update" -> Json -> Update
AvailableCommandsUpdate Json
upd
    Text
"session_info_update" -> Json -> Update
SessionInfoUpdate Json
upd
    Text
"usage_update" -> Json -> Update
UsageUpdate Json
upd
    Text
other -> Text -> Json -> Update
UnknownUpdate Text
other Json
upd
  where
    contentText :: Json -> Text
contentText Json
upd =
      Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Text -> Json -> Maybe Json
objLookup Text
"content" Json
upd Maybe Json -> (Json -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Json -> Maybe Text
textAt Text
"text")

-- ---------------------------------------------------------------------------
-- Send / receive
-- ---------------------------------------------------------------------------

-- | Encode and commit one JSON-RPC message line, logging the raw frame.
acpSendValue :: AcpClient -> Json -> IO ()
acpSendValue :: AcpClient -> Json -> IO ()
acpSendValue AcpClient
c Json
v = do
  let line :: Text
line = Json -> Text
encodeJsonText Json
v
  AcpClient -> Text -> Text -> IO ()
logFrame AcpClient
c Text
"send" Text
line
  K IO Text () -> Text -> IO ()
forall {k} (m :: k -> *) a (b :: k). K m a b -> a -> m b
runK
    (In (K IO) Text -> forall x. Out (K IO) x -> K IO Text x
forall {k1} {k2} (arr :: k1 -> k2 -> *) (a :: k1).
In arr a -> forall (x :: k2). Out arr x -> arr a x
commit (StdPorts Text Text Text -> In (K IO) Text
forall a b c. StdPorts a b c -> In (K IO) a
stdIn (AcpClient -> StdPorts Text Text Text
acpPorts AcpClient
c)) (Poles (K IO) () () -> Out (K IO) ()
forall {k1} {k2} (arr :: k1 -> k2 -> *) (a :: k1) (b :: k2).
Poles arr a b -> Out arr b
companion (Poles (K IO) () ()
forall {k} (bot :: k) (arr :: k -> k -> *).
HasDual bot arr =>
Poles arr bot bot
open :: Poles (K IO) () ())))
    Text
line

-- | Read the next stdout line, blocking until a complete line frame
-- arrives, logging raw frames.
acpReadLine :: AcpClient -> IO Text
acpReadLine :: AcpClient -> IO Text
acpReadLine AcpClient
c = do
  t <-
    K IO () Text -> () -> IO Text
forall {k} (m :: k -> *) a (b :: k). K m a b -> a -> m b
runK
      (Out (K IO) Text -> forall x. In (K IO) x -> K IO x Text
forall {k1} {k2} (arr :: k1 -> k2 -> *) (a :: k2).
Out arr a -> forall (x :: k1). In arr x -> arr x a
emit (StdPorts Text Text Text -> Out (K IO) Text
forall a b c. StdPorts a b c -> Out (K IO) b
stdOut (AcpClient -> StdPorts Text Text Text
acpPorts AcpClient
c)) (Poles (K IO) () () -> In (K IO) ()
forall {k1} {k2} (arr :: k1 -> k2 -> *) (a :: k1) (b :: k2).
Poles arr a b -> In arr a
conjoint (Poles (K IO) () ()
forall {k} (bot :: k) (arr :: k -> k -> *).
HasDual bot arr =>
Poles arr bot bot
open :: Poles (K IO) () ())))
      ()
  logFrame c "recv" t
  pure t

-- | Read the next decodable JSON message, blocking on the stdout queue
-- until one arrives or the timeout (microseconds) expires.  Lines that fail
-- to parse are skipped (they stay in the transcript).
acpReadFrame :: AcpClient -> Int -> IO (Maybe Json)
acpReadFrame :: AcpClient -> Int -> IO (Maybe Json)
acpReadFrame AcpClient
c Int
micros = Int -> IO Json -> IO (Maybe Json)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
micros IO Json
go
  where
    go :: IO Json
go = do
      t <- AcpClient -> IO Text
acpReadLine AcpClient
c
      if T.null t
        then go
        else case decodeJson (encodeUtf8 t) of
          Right Json
v -> Json -> IO Json
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Json
v
          Left FilePath
_ -> IO Json
go

-- ---------------------------------------------------------------------------
-- Reverse-RPC
-- ---------------------------------------------------------------------------

-- | kimi sends @uri@ with a @file:\/\/\/\/@ prefix where the ACP schema says
-- @path@; accept both.
uriPath :: Json -> Maybe FilePath
uriPath :: Json -> Maybe FilePath
uriPath Json
params = case Text -> Json -> Maybe Text
textAt Text
"uri" Json
params of
  Just Text
u -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (Text -> FilePath
T.unpack (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
u (Text -> Text -> Maybe Text
T.stripPrefix Text
"file://" Text
u)))
  Maybe Text
Nothing -> Text -> FilePath
T.unpack (Text -> FilePath) -> Maybe Text -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Json -> Maybe Text
textAt Text
"path" Json
params

sendResult :: AcpClient -> Int -> Json -> IO ()
sendResult :: AcpClient -> Int -> Json -> IO ()
sendResult AcpClient
c Int
rid Json
r =
  AcpClient -> Json -> IO ()
acpSendValue AcpClient
c ([(Text, Json)] -> Json
jobject [(Text
"jsonrpc", Text -> Json
jtext Text
t2), (Text
"id", Int -> Json
forall a. Integral a => a -> Json
jnum Int
rid), (Text
"result", Json
r)])
  where
    t2 :: Text
t2 = Text
"2.0" :: Text

sendError :: AcpClient -> Int -> Int -> Text -> IO ()
sendError :: AcpClient -> Int -> Int -> Text -> IO ()
sendError AcpClient
c Int
rid Int
code Text
msg =
  AcpClient -> Json -> IO ()
acpSendValue
    AcpClient
c
    ( [(Text, Json)] -> Json
jobject
        [ (Text
"jsonrpc", Text -> Json
jtext Text
t2),
          (Text
"id", Int -> Json
forall a. Integral a => a -> Json
jnum Int
rid),
          (Text
"error", [(Text, Json)] -> Json
jobject [(Text
"code", Int -> Json
forall a. Integral a => a -> Json
jnum Int
code), (Text
"message", Text -> Json
jtext Text
msg)])
        ]
    )
  where
    t2 :: Text
t2 = Text
"2.0" :: Text

-- | Answer a reverse-RPC from the agent.
--
-- @fs\/*@ are the auto-mode file channel (answered for real);
-- @session\/request_permission@ gets a best-effort schema-shaped approval
-- (kimi 0.33.0 mishandles every known response shape — switch to @auto@
-- mode instead); anything else gets @-32601@.
acpAnswer :: AcpClient -> Int -> Text -> Json -> IO ()
acpAnswer :: AcpClient -> Int -> Text -> Json -> IO ()
acpAnswer AcpClient
c Int
rid Text
method Json
params = case Text
method of
  Text
"fs/read_text_file" -> case Json -> Maybe FilePath
uriPath Json
params of
    Maybe FilePath
Nothing -> AcpClient -> Int -> Int -> Text -> IO ()
sendError AcpClient
c Int
rid (-Int
32602) Text
"fs/read_text_file: missing uri/path"
    Just FilePath
p -> do
      r <- forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException (FilePath -> IO Text
TIO.readFile FilePath
p)
      case r of
        Right Text
content -> AcpClient -> Int -> Json -> IO ()
sendResult AcpClient
c Int
rid ([(Text, Json)] -> Json
jobject [(Text
"content", Text -> Json
jtext Text
content)])
        Left SomeException
e -> AcpClient -> Int -> Int -> Text -> IO ()
sendError AcpClient
c Int
rid (-Int
32000) (FilePath -> Text
T.pack (SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e))
  Text
"fs/write_text_file" -> case Json -> Maybe FilePath
uriPath Json
params of
    Maybe FilePath
Nothing -> AcpClient -> Int -> Int -> Text -> IO ()
sendError AcpClient
c Int
rid (-Int
32602) Text
"fs/write_text_file: missing uri/path"
    Just FilePath
p -> do
      let content :: Text
content = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Text -> Json -> Maybe Text
textAt Text
"content" Json
params)
      r <-
        forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException
          (Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (ShowS
takeDirectory FilePath
p) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> Text -> IO ()
TIO.writeFile FilePath
p Text
content)
      case r of
        Right () -> AcpClient -> Int -> Json -> IO ()
sendResult AcpClient
c Int
rid ([(Text, Json)] -> Json
jobject [])
        Left SomeException
e -> AcpClient -> Int -> Int -> Text -> IO ()
sendError AcpClient
c Int
rid (-Int
32000) (FilePath -> Text
T.pack (SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e))
  Text
"session/request_permission" ->
    AcpClient -> Int -> Json -> IO ()
sendResult
      AcpClient
c
      Int
rid
      ( [(Text, Json)] -> Json
jobject
          [ ( Text
"outcome",
              [(Text, Json)] -> Json
jobject
                [(Text
"outcome", Text -> Json
jtext (Text
"selected" :: Text)), (Text
"optionId", Text -> Json
jtext Text
firstOption)]
            )
          ]
      )
  Text
_ -> AcpClient -> Int -> Int -> Text -> IO ()
sendError AcpClient
c Int
rid (-Int
32601) (Text
"method not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
method)
  where
    firstOption :: Text
firstOption = case Text -> Json -> Maybe Json
objLookup Text
"options" Json
params of
      Just (JArray Vector Json
os) ->
        Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"approve_once" ([Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe ((Json -> Maybe Text) -> [Json] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text -> Json -> Maybe Text
textAt Text
"optionId") ((Json -> [Json] -> [Json]) -> [Json] -> Vector Json -> [Json]
forall a b. (a -> b -> b) -> b -> Vector a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (:) [] Vector Json
os)))
      Maybe Json
_ -> Text
"approve_once"

-- ---------------------------------------------------------------------------
-- Requests
-- ---------------------------------------------------------------------------

-- | Send a request and block until its response arrives or the timeout
-- (microseconds) expires.  Interleaved reverse-RPCs are answered (see
-- 'acpAnswer'); every frame seen (including the response) is returned in
-- arrival order alongside the response.
acpRequest :: AcpClient -> Int -> Text -> Json -> IO (Maybe Json, [Json])
acpRequest :: AcpClient -> Int -> Text -> Json -> IO (Maybe Json, [Json])
acpRequest AcpClient
c Int
micros Text
method Json
params = do
  rid <- IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (AcpClient -> IORef Int
acpNextId AcpClient
c) (\Int
i -> (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
i))
  acpSendValue
    c
    ( jobject
        [ ("jsonrpc", jtext t2),
          ("id", jnum rid),
          ("method", jtext method),
          ("params", params)
        ]
    )
  start <- getCurrentTime
  loop rid [] start
  where
    t2 :: Text
t2 = Text
"2.0" :: Text
    budgetLeft :: UTCTime -> IO Int
budgetLeft UTCTime
start = do
      now <- IO UTCTime
getCurrentTime
      pure (micros - round (realToFrac (diffUTCTime now start) * 1e6 :: Double))
    loop :: Int -> [Json] -> UTCTime -> IO (Maybe Json, [Json])
loop Int
rid [Json]
acc UTCTime
start = do
      left <- UTCTime -> IO Int
budgetLeft UTCTime
start
      if left <= 0
        then pure (Nothing, reverse acc)
        else do
          mv <- acpReadFrame c left
          case mv of
            Maybe Json
Nothing -> (Maybe Json, [Json]) -> IO (Maybe Json, [Json])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Json
forall a. Maybe a
Nothing, [Json] -> [Json]
forall a. [a] -> [a]
reverse [Json]
acc)
            Just Json
v -> case Json -> Maybe Frame
classifyFrame Json
v of
              Just (Response Int
i Json
_) | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
rid -> (Maybe Json, [Json]) -> IO (Maybe Json, [Json])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Json -> Maybe Json
forall a. a -> Maybe a
Just Json
v, [Json] -> [Json]
forall a. [a] -> [a]
reverse (Json
v Json -> [Json] -> [Json]
forall a. a -> [a] -> [a]
: [Json]
acc))
              Just (AgentRequest Int
i Text
m Json
p) -> do
                AcpClient -> Int -> Text -> Json -> IO ()
acpAnswer AcpClient
c Int
i Text
m Json
p
                Int -> [Json] -> UTCTime -> IO (Maybe Json, [Json])
loop Int
rid (Json
v Json -> [Json] -> [Json]
forall a. a -> [a] -> [a]
: [Json]
acc) UTCTime
start
              Maybe Frame
_ -> Int -> [Json] -> UTCTime -> IO (Maybe Json, [Json])
loop Int
rid (Json
v Json -> [Json] -> [Json]
forall a. a -> [a] -> [a]
: [Json]
acc) UTCTime
start

-- | @initialize@ handshake: protocolVersion 1, fs client capabilities on,
-- terminal off.
acpInitialize :: AcpClient -> Int -> IO (Maybe Json, [Json])
acpInitialize :: AcpClient -> Int -> IO (Maybe Json, [Json])
acpInitialize AcpClient
c Int
micros =
  AcpClient -> Int -> Text -> Json -> IO (Maybe Json, [Json])
acpRequest
    AcpClient
c
    Int
micros
    Text
"initialize"
    ( [(Text, Json)] -> Json
jobject
        [ (Text
"protocolVersion", Int -> Json
forall a. Integral a => a -> Json
jnum (Int
1 :: Int)),
          ( Text
"clientInfo",
            [(Text, Json)] -> Json
jobject
              [(Text
"name", Text -> Json
jtext (Text
"free-agent-acp" :: Text)), (Text
"version", Text -> Json
jtext (Text
"0.1.0" :: Text))]
          ),
          ( Text
"clientCapabilities",
            [(Text, Json)] -> Json
jobject
              [(Text
"fs", [(Text, Json)] -> Json
jobject [(Text
"readTextFile", Bool -> Json
jbool Bool
True), (Text
"writeTextFile", Bool -> Json
jbool Bool
True)]), (Text
"terminal", Bool -> Json
jbool Bool
False)]
          )
        ]
    )

-- | @session/new@ with the session cwd pinned.  Returns the sessionId on
-- success.
acpNewSession :: AcpClient -> Int -> FilePath -> IO (Maybe Text, [Json])
acpNewSession :: AcpClient -> Int -> FilePath -> IO (Maybe Text, [Json])
acpNewSession AcpClient
c Int
micros FilePath
cwd = do
  (mresp, msgs) <-
    AcpClient -> Int -> Text -> Json -> IO (Maybe Json, [Json])
acpRequest
      AcpClient
c
      Int
micros
      Text
"session/new"
      ([(Text, Json)] -> Json
jobject [(Text
"cwd", Text -> Json
jtext (FilePath -> Text
T.pack FilePath
cwd)), (Text
"mcpServers", [Json] -> Json
jarray [])])
  pure (mresp >>= resultOf >>= textAt "sessionId", msgs)

-- | @session/set_config_option@ — returns the full configOptions array.
acpSetConfigOption ::
  AcpClient -> Int -> Text -> Text -> Text -> IO (Maybe Json, [Json])
acpSetConfigOption :: AcpClient -> Int -> Text -> Text -> Text -> IO (Maybe Json, [Json])
acpSetConfigOption AcpClient
c Int
micros Text
sid Text
configId Text
value =
  AcpClient -> Int -> Text -> Json -> IO (Maybe Json, [Json])
acpRequest
    AcpClient
c
    Int
micros
    Text
"session/set_config_option"
    ( [(Text, Json)] -> Json
jobject
        [ (Text
"sessionId", Text -> Json
jtext Text
sid),
          (Text
"configId", Text -> Json
jtext Text
configId),
          (Text
"value", Text -> Json
jtext Text
value)
        ]
    )

-- | Switch a session to @auto@ mode.  Do NOT use @session\/set_mode@ — it
-- hangs in kimi 0.33.0.
acpSetModeAuto :: AcpClient -> Int -> Text -> IO (Maybe Json, [Json])
acpSetModeAuto :: AcpClient -> Int -> Text -> IO (Maybe Json, [Json])
acpSetModeAuto AcpClient
c Int
micros Text
sid = AcpClient -> Int -> Text -> Text -> Text -> IO (Maybe Json, [Json])
acpSetConfigOption AcpClient
c Int
micros Text
sid Text
"mode" Text
"auto"

-- | The result of one prompt turn.
data PromptResult = PromptResult
  { -- | Assembled @agent_message_chunk@ text (the reply).
    PromptResult -> Text
prReply :: Text,
    -- | Assembled @agent_thought_chunk@ text (interiority).
    PromptResult -> Text
prThoughts :: Text,
    -- | @stopReason@ from the @session\/prompt@ response.
    PromptResult -> Maybe Text
prStopReason :: Maybe Text,
    -- | All parsed session updates, in arrival order.
    PromptResult -> [Update]
prUpdates :: [Update],
    -- | Every raw frame seen during the turn.
    PromptResult -> [Json]
prMessages :: [Json]
  }
  deriving (Int -> PromptResult -> ShowS
[PromptResult] -> ShowS
PromptResult -> FilePath
(Int -> PromptResult -> ShowS)
-> (PromptResult -> FilePath)
-> ([PromptResult] -> ShowS)
-> Show PromptResult
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PromptResult -> ShowS
showsPrec :: Int -> PromptResult -> ShowS
$cshow :: PromptResult -> FilePath
show :: PromptResult -> FilePath
$cshowList :: [PromptResult] -> ShowS
showList :: [PromptResult] -> ShowS
Show)

-- | @session/prompt@ with a single text block.  Streams are collected
-- until the prompt response, then drained briefly for trailing
-- notifications (@usage_update@ arrives after the response).
acpPrompt :: AcpClient -> Int -> Text -> Text -> IO PromptResult
acpPrompt :: AcpClient -> Int -> Text -> Text -> IO PromptResult
acpPrompt AcpClient
c Int
micros Text
sid Text
promptText = do
  (mresp, msgs) <-
    AcpClient -> Int -> Text -> Json -> IO (Maybe Json, [Json])
acpRequest
      AcpClient
c
      Int
micros
      Text
"session/prompt"
      ( [(Text, Json)] -> Json
jobject
          [ (Text
"sessionId", Text -> Json
jtext Text
sid),
            ( Text
"prompt",
              [Json] -> Json
jarray [[(Text, Json)] -> Json
jobject [(Text
"type", Text -> Json
jtext (Text
"text" :: Text)), (Text
"text", Text -> Json
jtext Text
promptText)]]
            )
          ]
      )
  trailing <- drain
  let allMsgs = [Json]
msgs [Json] -> [Json] -> [Json]
forall a. Semigroup a => a -> a -> a
<> [Json]
trailing
      updates =
        [ Update
u
        | Just (Notification Text
"session/update" Json
ps) <- (Json -> Maybe Frame) -> [Json] -> [Maybe Frame]
forall a b. (a -> b) -> [a] -> [b]
map Json -> Maybe Frame
classifyFrame [Json]
allMsgs,
          Just Update
u <- [Json -> Maybe Update
parseUpdate Json
ps]
        ]
      reply = [Text] -> Text
T.concat [Text
t | AgentMessageChunk Text
t <- [Update]
updates]
      thoughts = [Text] -> Text
T.concat [Text
t | AgentThoughtChunk Text
t <- [Update]
updates]
      stop = Maybe Json
mresp Maybe Json -> (Json -> Maybe Json) -> Maybe Json
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Json -> Maybe Json
resultOf Maybe Json -> (Json -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Json -> Maybe Text
textAt Text
"stopReason"
  pure
    PromptResult
      { prReply = reply,
        prThoughts = thoughts,
        prStopReason = stop,
        prUpdates = updates,
        prMessages = allMsgs
      }
  where
    -- Read until 500ms idle, answering any late reverse-RPCs.
    drain :: IO [Json]
drain = [Json] -> IO [Json]
go []
      where
        go :: [Json] -> IO [Json]
go [Json]
acc = do
          mv <- AcpClient -> Int -> IO (Maybe Json)
acpReadFrame AcpClient
c Int
500000
          case mv of
            Maybe Json
Nothing -> [Json] -> IO [Json]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Json] -> [Json]
forall a. [a] -> [a]
reverse [Json]
acc)
            Just Json
v -> do
              case Json -> Maybe Frame
classifyFrame Json
v of
                Just (AgentRequest Int
i Text
m Json
p) -> AcpClient -> Int -> Text -> Json -> IO ()
acpAnswer AcpClient
c Int
i Text
m Json
p
                Maybe Frame
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              [Json] -> IO [Json]
go (Json
v Json -> [Json] -> [Json]
forall a. a -> [a] -> [a]
: [Json]
acc)

-- | @session/cancel@ notification — cancels the current turn.
acpCancel :: AcpClient -> Text -> IO ()
acpCancel :: AcpClient -> Text -> IO ()
acpCancel AcpClient
c Text
sid =
  AcpClient -> Json -> IO ()
acpSendValue
    AcpClient
c
    ( [(Text, Json)] -> Json
jobject
        [ (Text
"jsonrpc", Text -> Json
jtext Text
t2),
          (Text
"method", Text -> Json
jtext (Text
"session/cancel" :: Text)),
          (Text
"params", [(Text, Json)] -> Json
jobject [(Text
"sessionId", Text -> Json
jtext Text
sid)])
        ]
    )
  where
    t2 :: Text
t2 = Text
"2.0" :: Text

-- ---------------------------------------------------------------------------
-- Misc
-- ---------------------------------------------------------------------------

-- | Drain pending stderr diagnostics (bounded: returns after ~100ms of
-- quiet).  Stderr is diagnostics, not dialogue — a bounded drain, not a
-- blocking read, so a silent stderr cannot stall the caller.
acpReadStderr :: AcpClient -> IO Text
acpReadStderr :: AcpClient -> IO Text
acpReadStderr AcpClient
c = [Text] -> IO Text
go []
  where
    go :: [Text] -> IO Text
go [Text]
acc = do
      m <-
        Int -> IO Text -> IO (Maybe Text)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
100_000 (IO Text -> IO (Maybe Text)) -> IO Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$
          K IO () Text -> () -> IO Text
forall {k} (m :: k -> *) a (b :: k). K m a b -> a -> m b
runK
            (Out (K IO) Text -> forall x. In (K IO) x -> K IO x Text
forall {k1} {k2} (arr :: k1 -> k2 -> *) (a :: k2).
Out arr a -> forall (x :: k1). In arr x -> arr x a
emit (StdPorts Text Text Text -> Out (K IO) Text
forall a b c. StdPorts a b c -> Out (K IO) c
stdErr (AcpClient -> StdPorts Text Text Text
acpPorts AcpClient
c)) (Poles (K IO) () () -> In (K IO) ()
forall {k1} {k2} (arr :: k1 -> k2 -> *) (a :: k1) (b :: k2).
Poles arr a b -> In arr a
conjoint (Poles (K IO) () ()
forall {k} (bot :: k) (arr :: k -> k -> *).
HasDual bot arr =>
Poles arr bot bot
open :: Poles (K IO) () ())))
            ()
      case m of
        Maybe Text
Nothing -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> Text
T.unlines ([Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
acc))
        Just Text
l -> [Text] -> IO Text
go (Text
l Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc)