pms-infra-agent-serial-0.0.1.0: test/PMS/Infra/Agent/Serial/App/ControlSpec.hs
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
module PMS.Infra.Agent.Serial.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 qualified Data.ByteString as BS
import System.IO
import System.Log.FastLogger
import qualified System.Log.FastLogger as FastLogger
import qualified PMS.Domain.Model.DM.Type as DM
import qualified PMS.Domain.Model.DS.Utility as DM
import qualified PMS.Infra.Agent.Serial.App.Control as SUT
import qualified PMS.Infra.Agent.Serial.DM.Type as SUT
import qualified PMS.Infra.Agent.Serial.DS.Core as Core
import qualified PMS.Infra.Agent.Serial.DS.Utility as Util
-- |
--
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."
-- |
--
run :: SpecWith SpecContext
run = do
---------------------------------------------------------------------------
-- TC-01: echo — Verify overall flow
---------------------------------------------------------------------------
describe "TC-01: echo command" $ do
context "when echo command issued via runWithAppData" $ do
it "should return response with matching jsonrpc" $ \ctx -> do
putStrLn "[INFO] TC-01 start."
let domDat = ctx^.domainDataSpecContext
appDat = ctx^.appDataSpecContext
cmdQ = domDat^.DM.agentSerialQueueDomainData
resQ = domDat^.DM.responseQueueDomainData
expect = "tc-01-echo"
jsonR = def { DM._jsonrpcJsonRpcRequest = expect }
argDat = DM.AgentSerialEchoCommandData jsonR expect
args = DM.AgentSerialEchoCommand argDat
thId <- async $ SUT.runWithAppData appDat domDat
STM.atomically $ STM.writeTQueue cmdQ args
(DM.McpToolsCallResponse dat) <- STM.atomically $ STM.readTQueue resQ
cancel thId
let actual = dat^.DM.jsonrpcMcpToolsCallResponseData^.DM.jsonrpcJsonRpcRequest
actual `shouldBe` expect
---------------------------------------------------------------------------
-- TC-02: agent-serial-open — Guard against multiple opens
---------------------------------------------------------------------------
describe "TC-02: agent-serial-open double open" $ do
context "when handle is already Just (serial already connected)" $ do
it "should return isError=True with 'serial is already connected.'" $ \_ -> do
putStrLn "[INFO] TC-02 start."
pendingWith "requires a real SerialPort or an injected SerialPort adapter"
---------------------------------------------------------------------------
-- TC-03: agent-serial-close — Close without connection
---------------------------------------------------------------------------
describe "TC-03: agent-serial-close without open" $ do
context "when handle is Nothing" $ do
it "should return isError=True with 'serial is not connected.'" $ \ctx -> do
putStrLn "[INFO] TC-03 start."
let domDat = ctx^.domainDataSpecContext
appDat = ctx^.appDataSpecContext
resQ = domDat^.DM.responseQueueDomainData
cmdDat = DM.AgentSerialCloseCommandData
{ DM._jsonrpcAgentSerialCloseCommandData = mkJsonRpc "agent-serial-close"
}
Core.serialCloseTask cmdDat resQ (appDat^.SUT.serialPortAppData)
(DM.McpToolsCallResponse dat) <- STM.atomically $ STM.readTQueue resQ
isError dat `shouldBe` True
secondContentText dat `shouldBe` "serial is not connected."
---------------------------------------------------------------------------
-- TC-04: agent-serial-close — Normal close
---------------------------------------------------------------------------
describe "TC-04: agent-serial-close with open handle" $ do
context "when handle is Just hdl" $ do
it "should return isError=False and handle becomes Nothing" $ \_ -> do
putStrLn "[INFO] TC-04 start."
pendingWith "requires a real SerialPort or an injected SerialPort adapter"
---------------------------------------------------------------------------
-- TC-05: agent-serial-read — Not connected
---------------------------------------------------------------------------
describe "TC-05: agent-serial-read without open" $ do
context "when handle is Nothing" $ do
it "should return isError=True with 'serial is not connected.'" $ \ctx -> do
putStrLn "[INFO] TC-05 start."
let domDat = ctx^.domainDataSpecContext
appDat = ctx^.appDataSpecContext
resQ = domDat^.DM.responseQueueDomainData
cmdDat = DM.AgentSerialReadCommandData
{ DM._jsonrpcAgentSerialReadCommandData = mkJsonRpc "agent-serial-read"
, DM._argumentsAgentSerialReadCommandData = DM.RawJsonByteString ""
}
Core.serialReadTask cmdDat resQ (appDat^.SUT.serialPortAppData) 16
(DM.McpToolsCallResponse dat) <- STM.atomically $ STM.readTQueue resQ
isError dat `shouldBe` True
secondContentText dat `shouldBe` "serial is not connected."
---------------------------------------------------------------------------
-- TC-06: agent-serial-read — UTF-8 read
---------------------------------------------------------------------------
describe "TC-06: agent-serial-read UTF-8 string" $ do
context "when handle has UTF-8 bytes" $ do
it "should decode bytes as UTF-8 string" $ \_ -> do
putStrLn "[INFO] TC-06 start."
pendingWith "requires a real SerialPort or an injected SerialPort adapter"
---------------------------------------------------------------------------
-- TC-07: agent-serial-read-byte — Binary read
---------------------------------------------------------------------------
describe "TC-07: agent-serial-read-byte binary data" $ do
context "when handle has binary bytes" $ do
it "should encode bytes as uppercase hex string" $ \_ -> do
putStrLn "[INFO] TC-07 start."
DM.bytesToHex (BS.pack [0x00, 0x0A, 0x1B, 0xFF]) `shouldBe` "000A1BFF"
---------------------------------------------------------------------------
-- TC-08: agent-serial-read — Timeout (no data)
---------------------------------------------------------------------------
describe "TC-08: agent-serial-read timeout (no data)" $ do
context "when handle has no data pending" $ do
it "should return isError=False with empty string" $ \_ -> do
putStrLn "[INFO] TC-08 start."
pendingWith "requires a real SerialPort or an injected SerialPort adapter"
---------------------------------------------------------------------------
-- TC-09: agent-serial-write — Not connected
---------------------------------------------------------------------------
describe "TC-09: agent-serial-write without open" $ do
context "when handle is Nothing" $ do
it "should return isError=True with 'serial is not connected.'" $ \ctx -> do
putStrLn "[INFO] TC-09 start."
let domDat = ctx^.domainDataSpecContext
appDat = ctx^.appDataSpecContext
resQ = domDat^.DM.responseQueueDomainData
cmdDat = DM.AgentSerialWriteCommandData
{ DM._jsonrpcAgentSerialWriteCommandData = mkJsonRpc "agent-serial-write"
, DM._argumentsAgentSerialWriteCommandData = DM.RawJsonByteString ""
}
Core.serialWriteTask cmdDat resQ (appDat^.SUT.serialPortAppData) "hello" Nothing
(DM.McpToolsCallResponse dat) <- STM.atomically $ STM.readTQueue resQ
isError dat `shouldBe` True
secondContentText dat `shouldBe` "serial is not connected."
---------------------------------------------------------------------------
-- TC-10: agent-serial-write — UTF-8 write
---------------------------------------------------------------------------
describe "TC-10: agent-serial-write UTF-8 string" $ do
context "when serial is connected and data is a UTF-8 string" $ do
it "should write UTF-8 encoded bytes to the serial port" $ \_ -> do
putStrLn "[INFO] TC-10 start."
pendingWith "requires a real SerialPort or an injected SerialPort adapter"
---------------------------------------------------------------------------
-- TC-A: agent-serial-write — appendNewline default (omitted) appends \n
---------------------------------------------------------------------------
describe "TC-A: agent-serial-write appendNewline default appends newline" $ do
context "when appendNewline is Nothing (default True) and input has no trailing newline" $ do
it "should append \\n to the transmitted bytes" $ \ctx -> do
putStrLn "[INFO] TC-A start."
let domDat = ctx^.domainDataSpecContext
appDat = ctx^.appDataSpecContext
argsJson = "{\"data\":\"hello\"}"
cmdDat = DM.AgentSerialWriteCommandData
{ DM._jsonrpcAgentSerialWriteCommandData = mkJsonRpc "agent-serial-write"
, DM._argumentsAgentSerialWriteCommandData = DM.RawJsonByteString argsJson
}
DM.appendCRLF "hello" `shouldBe` ("hello" ++ nativeLineEnding)
withStderrLogger $ \logger -> do
result <- Util.runApp domDat appDat logger (Core.genSerialWriteTask cmdDat)
case result of
Left errMsg -> expectationFailure $ "Expected Right but got Left: " ++ errMsg
Right _ -> return ()
---------------------------------------------------------------------------
-- TC-B: agent-serial-write — appendNewline=False suppresses newline
---------------------------------------------------------------------------
describe "TC-B: agent-serial-write appendNewline=False suppresses newline" $ do
context "when appendNewline is Just False" $ do
it "should NOT append \\n; transmitted bytes equal raw input" $ \ctx -> do
putStrLn "[INFO] TC-B start."
let domDat = ctx^.domainDataSpecContext
appDat = ctx^.appDataSpecContext
argsJson = "{\"data\":\"hello\",\"appendNewline\":false}"
cmdDat = DM.AgentSerialWriteCommandData
{ DM._jsonrpcAgentSerialWriteCommandData = mkJsonRpc "agent-serial-write"
, DM._argumentsAgentSerialWriteCommandData = DM.RawJsonByteString argsJson
}
withStderrLogger $ \logger -> do
result <- Util.runApp domDat appDat logger (Core.genSerialWriteTask cmdDat)
case result of
Left errMsg -> expectationFailure $ "Expected Right but got Left: " ++ errMsg
Right _ -> return ()
---------------------------------------------------------------------------
-- TC-11: agent-serial-write-byte — Uppercase hex write
---------------------------------------------------------------------------
describe "TC-11: agent-serial-write-byte uppercase hex" $ do
context "when data is uppercase hex string" $ do
it "should decode uppercase hex string" $ \_ -> do
putStrLn "[INFO] TC-11 start."
Util.hexToBytes "000A1BFF" `shouldBe` Right (BS.pack [0x00, 0x0A, 0x1B, 0xFF])
---------------------------------------------------------------------------
-- TC-12: agent-serial-write-byte — Lowercase/mixed hex write
---------------------------------------------------------------------------
describe "TC-12: agent-serial-write-byte lowercase/mixed-case hex" $ do
context "when data is lowercase or mixed-case hex string" $ do
it "should decode lowercase or mixed-case hex string" $ \_ -> do
putStrLn "[INFO] TC-12 start."
let expect = BS.pack [0x00, 0x0A, 0x1B, 0xFF]
mapM_ (\hex -> Util.hexToBytes hex `shouldBe` Right expect) ["000a1bff", "000a1BFF"]
---------------------------------------------------------------------------
-- TC-13: agent-serial-write-byte — Invalid hex
---------------------------------------------------------------------------
describe "TC-13: agent-serial-write-byte invalid hex string" $ do
context "when hex string contains non-hex characters" $ do
it "should return Left with hexToBytes error message" $ \ctx -> do
putStrLn "[INFO] TC-13 start."
let domDat = ctx^.domainDataSpecContext
appDat = ctx^.appDataSpecContext
argsJson = "{\"data\":\"ZZZZ\"}"
cmdDat = DM.AgentSerialWriteByteCommandData
{ DM._jsonrpcAgentSerialWriteByteCommandData = mkJsonRpc "agent-serial-write-byte"
, DM._argumentsAgentSerialWriteByteCommandData = DM.RawJsonByteString argsJson
}
withStderrLogger $ \logger -> do
result <- Util.runApp domDat appDat logger (Core.genSerialWriteByteTask cmdDat)
case result of
Left errMsg -> errMsg `shouldContain` "hexToBytes"
Right _ -> expectationFailure "Expected Left (hexToBytes error) but got Right"
---------------------------------------------------------------------------
-- TC-14: agent-serial-write — invalidPatterns rejection (exact match)
---------------------------------------------------------------------------
describe "TC-14: agent-serial-write rejected by invalidPatterns (exact match)" $ do
context "when input matches an invalidPatterns entry" $ do
it "should return Left with invalidPatterns error message" $ \ctx -> do
putStrLn "[INFO] TC-14 start."
let domDat = (ctx^.domainDataSpecContext)
{ DM._invalidPatternsDomainData = ["reboot"] }
appDat = ctx^.appDataSpecContext
argsJson = "{\"data\":\"reboot\"}"
cmdDat = DM.AgentSerialWriteCommandData
{ DM._jsonrpcAgentSerialWriteCommandData = mkJsonRpc "agent-serial-write"
, DM._argumentsAgentSerialWriteCommandData = DM.RawJsonByteString argsJson
}
withStderrLogger $ \logger -> do
result <- Util.runApp domDat appDat logger (Core.genSerialWriteTask cmdDat)
case result of
Left errMsg -> errMsg `shouldContain` "invalidPatterns"
Right _ -> expectationFailure "Expected Left (invalidPatterns error) but got Right"
---------------------------------------------------------------------------
-- TC-15: agent-serial-write — invalidPatterns rejection (regex partial match)
---------------------------------------------------------------------------
describe "TC-15: agent-serial-write rejected by invalidPatterns (regex partial match)" $ do
context "when input partially matches an invalidPatterns regex" $ do
it "should return Left with invalidPatterns error message" $ \ctx -> do
putStrLn "[INFO] TC-15 start."
let domDat = (ctx^.domainDataSpecContext)
{ DM._invalidPatternsDomainData = ["rm -rf"] }
appDat = ctx^.appDataSpecContext
argsJson = "{\"data\":\"sudo rm -rf /\"}"
cmdDat = DM.AgentSerialWriteCommandData
{ DM._jsonrpcAgentSerialWriteCommandData = mkJsonRpc "agent-serial-write"
, DM._argumentsAgentSerialWriteCommandData = DM.RawJsonByteString argsJson
}
withStderrLogger $ \logger -> do
result <- Util.runApp domDat appDat logger (Core.genSerialWriteTask cmdDat)
case result of
Left errMsg -> errMsg `shouldContain` "invalidPatterns"
Right _ -> expectationFailure "Expected Left (invalidPatterns error) but got Right"
---------------------------------------------------------------------------
-- TC-16: agent-serial-write — Empty invalidPatterns list (allow all)
---------------------------------------------------------------------------
describe "TC-16: agent-serial-write allowed when invalidPatterns is empty" $ do
context "when invalidPatterns is empty (allow all)" $ do
it "should return Right (task) without error" $ \ctx -> do
putStrLn "[INFO] TC-16 start."
let domDat = (ctx^.domainDataSpecContext)
{ DM._invalidPatternsDomainData = [] }
appDat = ctx^.appDataSpecContext
argsJson = "{\"data\":\"any string\"}"
cmdDat = DM.AgentSerialWriteCommandData
{ DM._jsonrpcAgentSerialWriteCommandData = mkJsonRpc "agent-serial-write"
, DM._argumentsAgentSerialWriteCommandData = DM.RawJsonByteString argsJson
}
withStderrLogger $ \logger -> do
result <- Util.runApp domDat appDat logger (Core.genSerialWriteTask cmdDat)
case result of
Left errMsg -> expectationFailure $ "Expected Right but got Left: " ++ errMsg
Right _ -> return ()
---------------------------------------------------------------------------------
-- Helpers
---------------------------------------------------------------------------------
mkJsonRpc :: String -> DM.JsonRpcRequest
mkJsonRpc method = def { DM._methodJsonRpcRequest = method }
isError :: DM.McpToolsCallResponseData -> Bool
isError dat =
dat^.DM.resultMcpToolsCallResponseData^.DM.isErrorMcpToolsCallResponseResult
secondContentText :: DM.McpToolsCallResponseData -> String
secondContentText dat =
let contents = dat^.DM.resultMcpToolsCallResponseData^.DM.contentMcpToolsCallResponseResult
in DM._textMcpToolsCallResponseResultContent (contents !! 1)
nativeLineEnding :: String
nativeLineEnding = case nativeNewline of
CRLF -> "\r\n"
LF -> "\n"
-- | For TC-13: Temporarily create and use a TimedFastLogger that outputs to stderr.
withStderrLogger :: (FastLogger.TimedFastLogger -> IO a) -> IO a
withStderrLogger action = do
tc <- newTimeCache "%Y-%m-%d %H:%M:%S"
(logger, finalizer) <- newTimedFastLogger tc (LogStderr defaultBufSize)
result <- action logger
finalizer
return result