ControlSpec.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}

module PMS.Infra.CmdRun.App.ControlSpec (spec) where

import Test.Hspec
import Control.Concurrent.Async
import qualified Control.Concurrent.STM as STM
import Control.Lens
import Data.Default
import Data.Aeson (encode)
import System.Directory (getCurrentDirectory)
import System.FilePath ((</>))

import qualified PMS.Domain.Model.DM.Type as DM
import qualified PMS.Infra.CmdRun.App.Control as SUT
import qualified PMS.Infra.CmdRun.DM.Type as SUT

-- |
--
data SpecContext = SpecContext {
                   _domainDataSpecContext :: DM.DomainData
                 , _appDataSpecContext    :: SUT.AppData
                 }

makeLenses ''SpecContext

defaultSpecContext :: IO SpecContext
defaultSpecContext = do
  domDat <- DM.defaultDomainData
  appDat <- SUT.defaultAppData
  return SpecContext {
           _domainDataSpecContext = domDat
         , _appDataSpecContext    = appDat
         }

-- |
--
spec :: Spec
spec = do
  runIO $ putStrLn "Start Spec."
  beforeAll setUpOnce $
    afterAll tearDownOnce .
      beforeWith setUp .
        after tearDown $ run

-- |
--
setUpOnce :: IO SpecContext
setUpOnce = do
  putStrLn "[INFO] EXECUTED ONLY ONCE BEFORE ALL TESTS START."
  defaultSpecContext

-- |
--
tearDownOnce :: SpecContext -> IO ()
tearDownOnce _ = do
  putStrLn "[INFO] EXECUTED ONLY ONCE AFTER ALL TESTS FINISH."

-- |
--
setUp :: SpecContext -> IO SpecContext
setUp ctx = do
  putStrLn "[INFO] EXECUTED BEFORE EACH TEST STARTS."
  domDat <- DM.defaultDomainData
  appDat <- SUT.defaultAppData
  return ctx {
               _domainDataSpecContext = domDat
             , _appDataSpecContext    = appDat
             }

-- |
--
tearDown :: SpecContext -> IO ()
tearDown _ = do
  putStrLn "[INFO] EXECUTED AFTER EACH TEST FINISHES."

-- ---------------------------------------------------------------------------
-- Helpers
-- ---------------------------------------------------------------------------

-- | Script directory used by TC-02 to TC-04.
-- Uses an absolute path so shells do not interpret the leading "test" segment
-- as the POSIX test command.
testScriptsDir :: IO String
testScriptsDir = do
  cwd <- getCurrentDirectory
  return $ cwd </> "test" </> "scripts"

-- | Build a RawJsonByteString that wraps StringToolParams.
mkArgs :: String -> DM.RawJsonByteString
mkArgs s = DM.RawJsonByteString $ encode
  (SUT.StringToolParams { SUT._argumentsStringToolParams = s })

-- | Send a DefaultCmdRunCommand and wait for one MCP response.
sendCmdRun :: DM.DomainData -> SUT.AppData -> String -> String -> IO DM.McpToolsCallResponseData
sendCmdRun domDat appDat name argsStr = do
  let cmdQ  = domDat^.DM.cmdRunQueueDomainData
      resQ  = domDat^.DM.responseQueueDomainData
      jsonR = def { DM._methodJsonRpcRequest = name }
      dat   = DM.DefaultCmdRunCommandData jsonR name (mkArgs argsStr)
      cmd   = DM.DefaultCmdRunCommand dat
  thId <- async $ SUT.runWithAppData appDat domDat
  STM.atomically $ STM.writeTQueue cmdQ cmd
  (DM.McpToolsCallResponse res) <- STM.atomically $ STM.readTQueue resQ
  cancel thId
  return res

-- | Extract the isError flag from a response.
isError :: DM.McpToolsCallResponseData -> Bool
isError dat =
  dat^.DM.resultMcpToolsCallResponseData^.DM.isErrorMcpToolsCallResponseResult

-- | Extract text of the first content entry (stdout).
firstText :: DM.McpToolsCallResponseData -> String
firstText dat =
  let cs = dat^.DM.resultMcpToolsCallResponseData^.DM.contentMcpToolsCallResponseResult
  in DM._textMcpToolsCallResponseResultContent (head cs)

-- | Extract text of the second content entry (stderr).
secondText :: DM.McpToolsCallResponseData -> String
secondText dat =
  let cs = dat^.DM.resultMcpToolsCallResponseData^.DM.contentMcpToolsCallResponseResult
  in DM._textMcpToolsCallResponseResultContent (cs !! 1)

-- ---------------------------------------------------------------------------
-- Test suite
-- ---------------------------------------------------------------------------

-- |
--
run :: SpecWith SpecContext
run = do

  -- TC-01: echo command (regression check)
  describe "TC-01: echo command" $ do
    context "when echo command issued." $ do
      it "should call callback" $ \ctx -> do
        putStrLn "[INFO] TC-01: EXECUTING ECHO TEST."

        let domDat = ctx^.domainDataSpecContext
            appDat = ctx^.appDataSpecContext
            cmdQ   = domDat^.DM.cmdRunQueueDomainData
            resQ   = domDat^.DM.responseQueueDomainData
            expect = "abc"
            jsonR  = def {DM._jsonrpcJsonRpcRequest = expect}
            argDat = DM.EchoCmdRunCommandData jsonR ""
            args   = DM.EchoCmdRunCommand argDat

        thId <- async $ SUT.runWithAppData appDat domDat

        STM.atomically $ STM.writeTQueue cmdQ args

        (DM.McpToolsCallResponse dat) <- STM.atomically $ STM.readTQueue resQ

        let actual = dat^.DM.jsonrpcMcpToolsCallResponseData^.DM.jsonrpcJsonRpcRequest
        actual `shouldBe` expect

        cancel thId

  -- TC-02: stdout-only command
  -- Verifies that stdout is correctly captured after the concurrent-read fix.
  describe "TC-02: stdout-only command" $ do
    context "when a command writes only to stdout" $ do
      it "should return isError=False and capture stdout" $ \ctx -> do
        putStrLn "[INFO] TC-02: EXECUTING STDOUT-ONLY TEST."

        let domDat  = ctx^.domainDataSpecContext
            appDat  = ctx^.appDataSpecContext
            token   = "hellostdout"
        scriptsDir <- testScriptsDir
        let domDat' = domDat { DM._toolsDirDomainData = scriptsDir }

        res <- sendCmdRun domDat' appDat "echo_stdout" token

        -- debug: print actual response for diagnosis
        putStrLn $ "[DEBUG] TC-02 isError: " ++ show (isError res)
        putStrLn $ "[DEBUG] TC-02 firstText: " ++ firstText res
        putStrLn $ "[DEBUG] TC-02 secondText: " ++ secondText res

        isError res           `shouldBe` False
        firstText res         `shouldContain` token

  -- TC-03: stderr-only command
  -- Verifies that stderr is correctly captured via the concurrent read thread.
  describe "TC-03: stderr-only command" $ do
    context "when a command writes only to stderr" $ do
      it "should return isError=False and capture stderr" $ \ctx -> do
        putStrLn "[INFO] TC-03: EXECUTING STDERR-ONLY TEST."

        let domDat  = ctx^.domainDataSpecContext
            appDat  = ctx^.appDataSpecContext
            token   = "hellostderr"
        scriptsDir <- testScriptsDir
        let domDat' = domDat { DM._toolsDirDomainData = scriptsDir }

        res <- sendCmdRun domDat' appDat "echo_stderr" token

        isError res            `shouldBe` False
        secondText res         `shouldContain` token

  -- TC-04: timeout
  -- Verifies that a long-running command is terminated within timeoutMicrosec
  -- and returns an error response containing "timeout occurred.".
  describe "TC-04: timeout" $ do
    context "when a command exceeds the timeout" $ do
      it "should return isError=True with 'timeout occurred.'" $ \ctx -> do
        putStrLn "[INFO] TC-04: EXECUTING TIMEOUT TEST."

        let domDat  = ctx^.domainDataSpecContext
            appDat  = ctx^.appDataSpecContext
        scriptsDir <- testScriptsDir
        let domDat' = domDat
              { DM._toolsDirDomainData        = scriptsDir
              , DM._timeoutMicrosecDomainData = 3 * 1000 * 1000
              }

        -- sleep.bat sleeps for 60 s, which exceeds the 3-second timeout.
        res <- sendCmdRun domDat' appDat "sleep" ""

        -- debug: print actual response for diagnosis
        putStrLn $ "[DEBUG] TC-04 isError: " ++ show (isError res)
        putStrLn $ "[DEBUG] TC-04 firstText: " ++ firstText res

        isError res   `shouldBe` True
        secondText res `shouldContain` "timeout occurred."