pms-infra-watch 0.0.1.0 → 0.0.2.0
raw patch · 4 files changed
+90/−36 lines, 4 files
Files
- CHANGELOG.md +4/−0
- pms-infra-watch.cabal +1/−1
- src/PMS/Infra/Watch/DS/Core.hs +81/−30
- test/PMS/Infra/Watch/App/ControlSpec.hs +4/−5
CHANGELOG.md view
@@ -1,5 +1,9 @@ # Revision history for pms-infra-watch +## 0.0.2.0 -- 2025-06-29++* Added prompts interface.+ ## 0.0.1.0 -- 2025-06-22 * First version.
pms-infra-watch.cabal view
@@ -20,7 +20,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.0.1.0+version: 0.0.2.0 -- A short (one-line) description of the package. synopsis: pms-infra-watch
src/PMS/Infra/Watch/DS/Core.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-} module PMS.Infra.Watch.DS.Core where @@ -16,14 +17,12 @@ import Control.Monad.Except import System.FilePath import qualified Control.Exception.Safe as E-import System.Exit import qualified System.FSNotify as S import qualified Data.Text.IO as T import qualified Data.Text.Encoding as TE import qualified Data.ByteString.Lazy as BL - import qualified PMS.Domain.Model.DM.Type as DM import qualified PMS.Domain.Model.DM.Constant as DM @@ -72,6 +71,7 @@ go :: DM.WatchCommand -> AppContext (IOTask ()) go (DM.EchoWatchCommand dat) = genEchoTask dat go (DM.ToolsListWatchCommand dat) = genToolsListWatchTask dat+ go (DM.PromptsListWatchCommand dat) = genPromptsListWatchTask dat --------------------------------------------------------------------------------- -- |@@ -92,9 +92,9 @@ go :: (IO ()) -> AppContext () go task = do- $logDebugS DM._LOGTAG "sink: start async."+ $logDebugS DM._LOGTAG "sink: start task." liftIOE task- $logDebugS DM._LOGTAG "sink: end async."+ $logDebugS DM._LOGTAG "sink: end task." return () ---------------------------------------------------------------------------------@@ -102,42 +102,30 @@ -- genEchoTask :: DM.EchoWatchCommandData -> AppContext (IOTask ()) genEchoTask dat = do- resQ <- view DM.responseQueueDomainData <$> lift ask+ notiQ <- view DM.notificationQueueDomainData <$> lift ask let val = dat^.DM.valueEchoWatchCommandData $logDebugS DM._LOGTAG $ T.pack $ "echoTask: echo : " ++ val- return $ echoTask resQ dat val+ return $ echoTask notiQ dat val -- |--- -echoTask :: STM.TQueue DM.McpResponse -> DM.EchoWatchCommandData -> String -> IOTask ()-echoTask resQ cmdDat val = flip E.catchAny errHdl $ do+--+echoTask :: STM.TQueue DM.McpNotification -> DM.EchoWatchCommandData -> String -> IOTask ()+echoTask notiQ _ val = flip E.catchAny errHdl $ do hPutStrLn stderr $ "[INFO] PMS.Infra.Watch.DS.Core.echoTask run. " ++ val - response ExitSuccess val ""+ let dat = def {DM._methodMcpToolsListChangedNotificationData = val}+ res = DM.McpToolsListChangedNotification dat + STM.atomically $ STM.writeTQueue notiQ res+ hPutStrLn stderr "[INFO] PMS.Infra.Watch.DS.Core.echoTask end." where errHdl :: E.SomeException -> IO ()- errHdl e = response (ExitFailure 1) "" (show e)-- response :: ExitCode -> String -> String -> IO ()- response code outStr errStr = do- let jsonRpc = cmdDat^.DM.jsonrpcEchoWatchCommandData- content = [ DM.McpToolsCallResponseResultContent "text" outStr- , DM.McpToolsCallResponseResultContent "text" errStr- ]- result = DM.McpToolsCallResponseResult {- DM._contentMcpToolsCallResponseResult = content- , DM._isErrorMcpToolsCallResponseResult = (ExitSuccess /= code)- }- resDat = DM.McpToolsCallResponseData jsonRpc result- res = DM.McpToolsCallResponse resDat-- STM.atomically $ STM.writeTQueue resQ res-+ errHdl e = hPutStrLn stderr $ "[INFO] PMS.Infra.Watch.DS.Core.echoTask.errHdl " ++ show e+ -- | -- genToolsListWatchTask :: DM.ToolsListWatchCommandData -> AppContext (IOTask ())@@ -172,7 +160,11 @@ isToolsListJson e = takeFileName (S.eventPath e) == DM._TOOLS_LIST_FILE onToolsListUpdated :: S.Event -> IO ()+#ifdef mingw32_HOST_OS+ onToolsListUpdated e@S.Modified{} = response $ S.eventPath e+#else onToolsListUpdated e@S.CloseWrite{} = response $ S.eventPath e+#endif onToolsListUpdated e = hPutStrLn stderr $ "[INFO] PMS.Infra.Watch.DS.Core.toolsListWatchTask ignore event: " ++ show e readToolsList :: FilePath -> IO BL.ByteString@@ -185,9 +177,68 @@ hPutStrLn stderr $ "[INFO] PMS.Infra.Watch.DS.Core.toolsListWatchTask.response called. " ++ toolFile tools <- readToolsList toolFile - let params = def {DM._toolsMcpToolListChangedNotificationDataParams = DM.RawJsonByteString tools}- dat = def {DM._paramsMcpToolListChangedNotificationData = params}- res = DM.McpToolListChangedNotification dat+ let params = def {DM._toolsMcpToolsListChangedNotificationDataParams = DM.RawJsonByteString tools}+ dat = def {DM._paramsMcpToolsListChangedNotificationData = params}+ res = DM.McpToolsListChangedNotification dat++ STM.atomically $ STM.writeTQueue notiQ res+++-- |+--+genPromptsListWatchTask :: DM.PromptsListWatchCommandData -> AppContext (IOTask ())+genPromptsListWatchTask dat = do+ promptsDir <- view DM.promptsDirDomainData <$> lift ask+ notiQ <- view DM.notificationQueueDomainData <$> lift ask+ mgrVar <- view watchManagerAppData <$> ask+ mgr <- liftIOE $ STM.atomically $ STM.readTMVar mgrVar+ let promptsJ = promptsDir </> DM._PROMPTS_LIST_FILE++ $logDebugS DM._LOGTAG $ T.pack $ "promptsListWatchTask: directory " ++ promptsDir+ $logDebugS DM._LOGTAG $ T.pack $ "promptsListWatchTask: file " ++ promptsJ++ return $ promptsListWatchTask notiQ dat mgr promptsDir+++-- |+--+promptsListWatchTask :: STM.TQueue DM.McpNotification -> DM.PromptsListWatchCommandData -> S.WatchManager -> String -> IOTask ()+promptsListWatchTask notiQ _ mgr promptsDir = flip E.catchAny errHdl $ do+ hPutStrLn stderr $ "[INFO] PMS.Infra.Watch.DS.Core.work.promptsListWatchTask run. "++ _stop <- S.watchTree mgr promptsDir isTargetFile onPromptsListUpdated++ hPutStrLn stderr "[INFO] PMS.Infra.Watch.DS.Core.promptsListWatchTask end."++ where+ errHdl :: E.SomeException -> IO ()+ errHdl e = hPutStrLn stderr $ "[ERROR] PMS.Infra.Watch.DS.Core.promptsListWatchTask exception occurred. " ++ show e++ isTargetFile :: S.Event -> Bool+ isTargetFile e =+ let file = takeFileName (S.eventPath e)+ ext = takeExtension file+ in file == DM._PROMPTS_LIST_FILE || ext `elem` [".md", ".txt", ".prompt"]++ onPromptsListUpdated :: S.Event -> IO ()+ onPromptsListUpdated e@S.CloseWrite{} = response $ S.eventPath e+ onPromptsListUpdated e = hPutStrLn stderr $ "[INFO] PMS.Infra.Watch.DS.Core.promptsListWatchTask ignore event: " ++ show e++ readPromptsList :: FilePath -> IO BL.ByteString+ readPromptsList path = do+ cont <- T.readFile path+ return $ BL.fromStrict $ TE.encodeUtf8 cont++ response :: String -> IO ()+ response updateFile = do+ hPutStrLn stderr $ "[INFO] PMS.Infra.Watch.DS.Core.promptsListWatchTask.response called. " ++ updateFile++ let promptsFile = promptsDir </> DM._PROMPTS_LIST_FILE+ prompts <- readPromptsList promptsFile++ let params = def {DM._promptsMcpPromptsListChangedNotificationDataParams = DM.RawJsonByteString prompts}+ dat = def {DM._paramsMcpPromptsListChangedNotificationData = params}+ res = DM.McpPromptsListChangedNotification dat STM.atomically $ STM.writeTQueue notiQ res
test/PMS/Infra/Watch/App/ControlSpec.hs view
@@ -85,19 +85,18 @@ let domDat = ctx^.domainDataSpecContext appDat = ctx^.appDataSpecContext cmdQ = domDat^.DM.watchQueueDomainData- resQ = domDat^.DM.responseQueueDomainData+ notiQ = domDat^.DM.notificationQueueDomainData expect = "abc"- jsonR = def {DM._jsonrpcJsonRpcRequest = expect}- argDat = DM.EchoWatchCommandData jsonR ""+ argDat = DM.EchoWatchCommandData def expect args = DM.EchoWatchCommand argDat thId <- async $ SUT.runWithAppData appDat domDat STM.atomically $ STM.writeTQueue cmdQ args - (DM.McpToolsCallResponse dat) <- STM.atomically $ STM.readTQueue resQ+ (DM.McpToolsListChangedNotification dat) <- STM.atomically $ STM.readTQueue notiQ - let actual = dat^.DM.jsonrpcMcpToolsCallResponseData^.DM.jsonrpcJsonRpcRequest+ let actual = dat^.DM.methodMcpToolsListChangedNotificationData actual `shouldBe` expect cancel thId