pms-domain-model 0.0.3.0 → 0.0.4.0
raw patch · 5 files changed
+629/−113 lines, 5 filesdep +strip-ansi-escape
Dependencies added: strip-ansi-escape
Files
- CHANGELOG.md +4/−0
- pms-domain-model.cabal +2/−1
- src/PMS/Domain/Model/DM/Constant.hs +11/−0
- src/PMS/Domain/Model/DM/Type.hs +446/−112
- src/PMS/Domain/Model/DS/Utility.hs +166/−0
CHANGELOG.md view
@@ -1,5 +1,9 @@ # Revision history for pms-domain-model +## 0.0.4.0 -- 2025-06-29++* Added prompts interface.+ ## 0.0.3.0 -- 2025-06-22 * Added file change monitoring for tools-list.json.
pms-domain-model.cabal view
@@ -20,7 +20,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.0.3.0+version: 0.0.4.0 -- A short (one-line) description of the package. synopsis: pms-domain-model@@ -82,6 +82,7 @@ bytestring, filepath, stm,+ strip-ansi-escape, safe-exceptions -- Directories containing source files.
src/PMS/Domain/Model/DM/Constant.hs view
@@ -20,3 +20,14 @@ _TOOLS_LIST_FILE :: String _TOOLS_LIST_FILE = "tools-list.json" +-- |+--+_PROMPTS_LIST_FILE :: String+_PROMPTS_LIST_FILE = "prompts-list.json"+++-- |+--+_LF :: String+_LF = "\n"+
src/PMS/Domain/Model/DM/Type.hs view
@@ -174,24 +174,8 @@ , _paramsMcpInitializeRequestData = def } - -- | ---data McpInitializedNotificationData =- McpInitializedNotificationData {- _jsonrpcMcpInitializedNotificationData :: JsonRpcRequest- } deriving (Show, Read, Eq)--$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpInitializedNotificationData", omitNothingFields = True} ''McpInitializedNotificationData)-makeLenses ''McpInitializedNotificationData--instance Default McpInitializedNotificationData where- def = McpInitializedNotificationData {- _jsonrpcMcpInitializedNotificationData = def- }---- |--- data McpToolsListRequestData = McpToolsListRequestData { _jsonrpcMcpToolsListRequestData :: JsonRpcRequest@@ -243,11 +227,154 @@ -- | --+data McpPromptsListRequestData =+ McpPromptsListRequestData {+ _jsonrpcMcpPromptsListRequestData :: JsonRpcRequest+ } deriving (Show, Read, Eq)++$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpPromptsListRequestData", omitNothingFields = True} ''McpPromptsListRequestData)+makeLenses ''McpPromptsListRequestData++instance Default McpPromptsListRequestData where+ def = McpPromptsListRequestData {+ _jsonrpcMcpPromptsListRequestData = def+ }++++-- |+--+data McpInitializedNotificationData =+ McpInitializedNotificationData {+ _jsonrpcMcpInitializedNotificationData :: JsonRpcRequest+ } deriving (Show, Read, Eq)++$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpInitializedNotificationData", omitNothingFields = True} ''McpInitializedNotificationData)+makeLenses ''McpInitializedNotificationData++instance Default McpInitializedNotificationData where+ def = McpInitializedNotificationData {+ _jsonrpcMcpInitializedNotificationData = def+ }+++-- |+--+data McpCancelledNotificationDataParams =+ McpCancelledNotificationDataParams {+ _requestIdMcpCancelledNotificationDataParams :: Int+ } deriving (Show, Read, Eq)++$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpCancelledNotificationDataParams", omitNothingFields = True} ''McpCancelledNotificationDataParams)+makeLenses ''McpCancelledNotificationDataParams++instance Default McpCancelledNotificationDataParams where+ def = McpCancelledNotificationDataParams {+ _requestIdMcpCancelledNotificationDataParams = def+ }++-- |+--+data McpCancelledNotificationData =+ McpCancelledNotificationData {+ _jsonrpcMcpCancelledNotificationData :: JsonRpcRequest+ , _paramsMcpCancelledNotificationData :: McpCancelledNotificationDataParams+ } deriving (Show, Read, Eq)++$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpCancelledNotificationData", omitNothingFields = True} ''McpCancelledNotificationData)+makeLenses ''McpCancelledNotificationData++instance Default McpCancelledNotificationData where+ def = McpCancelledNotificationData {+ _jsonrpcMcpCancelledNotificationData = def+ , _paramsMcpCancelledNotificationData = def+ }++++-- |+--+data McpCompletionCompleteRequestDataParams =+ McpCompletionCompleteRequestDataParams {+ _refMcpCompletionCompleteRequestDataParams :: RawJsonByteString+ , _argumentMcpCompletionCompleteRequestDataParams :: RawJsonByteString+ , _contextMcpCompletionCompleteRequestDataParams :: RawJsonByteString+ } deriving (Show, Read, Eq)++$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpCompletionCompleteRequestDataParams", omitNothingFields = True} ''McpCompletionCompleteRequestDataParams)+makeLenses ''McpCompletionCompleteRequestDataParams++instance Default McpCompletionCompleteRequestDataParams where+ def = McpCompletionCompleteRequestDataParams {+ _refMcpCompletionCompleteRequestDataParams = def+ , _argumentMcpCompletionCompleteRequestDataParams = def+ , _contextMcpCompletionCompleteRequestDataParams = def+ }++-- |+--+data McpCompletionCompleteRequestData =+ McpCompletionCompleteRequestData {+ _jsonrpcMcpCompletionCompleteRequestData :: JsonRpcRequest+ , _paramsMcpCompletionCompleteRequestData :: McpCompletionCompleteRequestDataParams+ } deriving (Show, Read, Eq)++$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpCompletionCompleteRequestData", omitNothingFields = True} ''McpCompletionCompleteRequestData)+makeLenses ''McpCompletionCompleteRequestData++instance Default McpCompletionCompleteRequestData where+ def = McpCompletionCompleteRequestData {+ _jsonrpcMcpCompletionCompleteRequestData = def+ , _paramsMcpCompletionCompleteRequestData = def+ }+++-- |+--+data McpPromptsGetRequestDataParams =+ McpPromptsGetRequestDataParams {+ _nameMcpPromptsGetRequestDataParams :: String+ , _argumentsMcpPromptsGetRequestDataParams :: RawJsonByteString+ } deriving (Show, Read, Eq)++$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpPromptsGetRequestDataParams", omitNothingFields = True} ''McpPromptsGetRequestDataParams)+makeLenses ''McpPromptsGetRequestDataParams++instance Default McpPromptsGetRequestDataParams where+ def = McpPromptsGetRequestDataParams {+ _nameMcpPromptsGetRequestDataParams = def+ , _argumentsMcpPromptsGetRequestDataParams = def+ }+++-- |+--+data McpPromptsGetRequestData =+ McpPromptsGetRequestData {+ _jsonrpcMcpPromptsGetRequestData :: JsonRpcRequest+ , _paramsMcpPromptsGetRequestData :: McpPromptsGetRequestDataParams+ } deriving (Show, Read, Eq)++$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpPromptsGetRequestData", omitNothingFields = True} ''McpPromptsGetRequestData)+makeLenses ''McpPromptsGetRequestData++instance Default McpPromptsGetRequestData where+ def = McpPromptsGetRequestData {+ _jsonrpcMcpPromptsGetRequestData = def+ , _paramsMcpPromptsGetRequestData = def+ }++-- |+-- data McpRequest = McpInitializeRequest McpInitializeRequestData- | McpInitializedNotification McpInitializedNotificationData | McpToolsListRequest McpToolsListRequestData | McpToolsCallRequest McpToolsCallRequestData+ | McpPromptsListRequest McpPromptsListRequestData+ | McpInitializedNotification McpInitializedNotificationData+ | McpCancelledNotification McpCancelledNotificationData+ | McpCompletionCompleteRequest McpCompletionCompleteRequestData+ | McpPromptsGetRequest McpPromptsGetRequestData deriving (Show, Read, Eq) --------------------------------------------------------------------------------@@ -263,8 +390,8 @@ instance Default McpInitializeResponseResultCapabilitiesResources where def = McpInitializeResponseResultCapabilitiesResources {- _subscribedMcpInitializeResponseResultCapabilitiesResources = def- , _listChangedMcpInitializeResponseResultCapabilitiesResources = def+ _subscribedMcpInitializeResponseResultCapabilitiesResources = True+ , _listChangedMcpInitializeResponseResultCapabilitiesResources = True } @@ -291,7 +418,7 @@ instance Default McpInitializeResponseResultCapabilitiesTools where def = McpInitializeResponseResultCapabilitiesTools {- _listChangedMcpInitializeResponseResultCapabilitiesTools = def+ _listChangedMcpInitializeResponseResultCapabilitiesTools = True } -- |@@ -299,7 +426,7 @@ data McpInitializeResponseResultCapabilities = McpInitializeResponseResultCapabilities { _toolsMcpInitializeResponseResultCapabilities :: McpInitializeResponseResultCapabilitiesTools- -- , _promptsMcpInitializeResponseResultCapabilities :: McpInitializeResponseResultCapabilitiesPrompts+ , _promptsMcpInitializeResponseResultCapabilities :: McpInitializeResponseResultCapabilitiesPrompts -- , _resourcesMcpInitializeResponseResultCapabilities :: McpInitializeResponseResultCapabilitiesResources } deriving (Show, Read, Eq) $(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpInitializeResponseResultCapabilities", omitNothingFields = True} ''McpInitializeResponseResultCapabilities)@@ -308,7 +435,7 @@ instance Default McpInitializeResponseResultCapabilities where def = McpInitializeResponseResultCapabilities { _toolsMcpInitializeResponseResultCapabilities = def- -- , _promptsMcpInitializeResponseResultCapabilities = def+ , _promptsMcpInitializeResponseResultCapabilities = def -- , _resourcesMcpInitializeResponseResultCapabilities = def } @@ -454,60 +581,236 @@ , _resultMcpToolsCallResponseData = def } +++ -- | --+data McpPromptsListResponseResult =+ McpPromptsListResponseResult {+ _promptsMcpPromptsListResponseResult :: RawJsonByteString+ } deriving (Show, Read, Eq)++$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpPromptsListResponseResult", omitNothingFields = True} ''McpPromptsListResponseResult)+makeLenses ''McpPromptsListResponseResult++instance Default McpPromptsListResponseResult where+ def = McpPromptsListResponseResult {+ _promptsMcpPromptsListResponseResult = def+ }++-- |+--+data McpPromptsListResponseData =+ McpPromptsListResponseData {+ _jsonrpcMcpPromptsListResponseData :: JsonRpcRequest+ , _resultMcpPromptsListResponseData :: McpPromptsListResponseResult+ } deriving (Show, Read, Eq)++$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpPromptsListResponseData", omitNothingFields = True} ''McpPromptsListResponseData)+makeLenses ''McpPromptsListResponseData++instance Default McpPromptsListResponseData where+ def = McpPromptsListResponseData {+ _jsonrpcMcpPromptsListResponseData = def+ , _resultMcpPromptsListResponseData = def+ }+++++-- |+--+data McpCompleteResponseResult =+ McpCompleteResponseResult {+ _valuesMcpCompleteResponseResult :: [String]+ } deriving (Show, Read, Eq)++$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpCompleteResponseResult", omitNothingFields = True} ''McpCompleteResponseResult)+makeLenses ''McpCompleteResponseResult++instance Default McpCompleteResponseResult where+ def = McpCompleteResponseResult {+ _valuesMcpCompleteResponseResult = def+ }++-- |+--+data McpCompleteResponseData =+ McpCompleteResponseData {+ _jsonrpcMcpCompleteResponseData :: JsonRpcRequest+ , _resultMcpCompleteResponseData :: McpCompleteResponseResult+ } deriving (Show, Read, Eq)++$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpCompleteResponseData", omitNothingFields = True} ''McpCompleteResponseData)+makeLenses ''McpCompleteResponseData++instance Default McpCompleteResponseData where+ def = McpCompleteResponseData {+ _jsonrpcMcpCompleteResponseData = def+ , _resultMcpCompleteResponseData = def+ }+++-- |+--+data McpTextContent =+ McpTextContent {+ _typeMcpTextContent :: String+ , _textMcpTextContent :: String+ } deriving (Show, Read, Eq)++$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpTextContent", omitNothingFields = True} ''McpTextContent)+makeLenses ''McpTextContent++instance Default McpTextContent where+ def = McpTextContent {+ _typeMcpTextContent = "text"+ , _textMcpTextContent = def+ }++-- |+--+data McpPromptsGetResponseResultPromptMessage =+ McpPromptsGetResponseResultPromptMessage {+ _roleMcpPromptsGetResponseResultPromptMessage :: String+ , _contentMcpPromptsGetResponseResultPromptMessage :: RawJsonByteString+ } deriving (Show, Read, Eq)++$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpPromptsGetResponseResultPromptMessage", omitNothingFields = True} ''McpPromptsGetResponseResultPromptMessage)+makeLenses ''McpPromptsGetResponseResultPromptMessage++instance Default McpPromptsGetResponseResultPromptMessage where+ def = McpPromptsGetResponseResultPromptMessage {+ _roleMcpPromptsGetResponseResultPromptMessage = "assistant"+ , _contentMcpPromptsGetResponseResultPromptMessage = def+ }+++-- |+--+data McpPromptsGetResponseResult =+ McpPromptsGetResponseResult {+ _messagesMcpPromptsGetResponseResult :: [McpPromptsGetResponseResultPromptMessage]+ } deriving (Show, Read, Eq)++$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpPromptsGetResponseResult", omitNothingFields = True} ''McpPromptsGetResponseResult)+makeLenses ''McpPromptsGetResponseResult++instance Default McpPromptsGetResponseResult where+ def = McpPromptsGetResponseResult {+ _messagesMcpPromptsGetResponseResult = def+ }++-- |+--+data McpPromptsGetResponseData =+ McpPromptsGetResponseData {+ _jsonrpcMcpPromptsGetResponseData :: JsonRpcRequest+ , _resultMcpPromptsGetResponseData :: McpPromptsGetResponseResult+ } deriving (Show, Read, Eq)++$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpPromptsGetResponseData", omitNothingFields = True} ''McpPromptsGetResponseData)+makeLenses ''McpPromptsGetResponseData++instance Default McpPromptsGetResponseData where+ def = McpPromptsGetResponseData {+ _jsonrpcMcpPromptsGetResponseData = def+ , _resultMcpPromptsGetResponseData = def+ }+++-- |+-- data McpResponse = McpInitializeResponse McpInitializeResponseData | McpToolsListResponse McpToolsListResponseData | McpToolsCallResponse McpToolsCallResponseData+ | McpPromptsListResponse McpPromptsListResponseData+ | McpCompleteResponse McpCompleteResponseData+ | McpPromptsGetResponse McpPromptsGetResponseData deriving (Show, Read, Eq) -------------------------------------------------------------------------------- -- | ---data McpToolListChangedNotificationDataParams =- McpToolListChangedNotificationDataParams {- _toolsMcpToolListChangedNotificationDataParams :: RawJsonByteString+data McpToolsListChangedNotificationDataParams =+ McpToolsListChangedNotificationDataParams {+ _toolsMcpToolsListChangedNotificationDataParams :: RawJsonByteString } deriving (Show, Read, Eq) -$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpToolListChangedNotificationDataParams", omitNothingFields = True} ''McpToolListChangedNotificationDataParams)-makeLenses ''McpToolListChangedNotificationDataParams+$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpToolsListChangedNotificationDataParams", omitNothingFields = True} ''McpToolsListChangedNotificationDataParams)+makeLenses ''McpToolsListChangedNotificationDataParams -instance Default McpToolListChangedNotificationDataParams where- def = McpToolListChangedNotificationDataParams {- _toolsMcpToolListChangedNotificationDataParams = RawJsonByteString "[]"+instance Default McpToolsListChangedNotificationDataParams where+ def = McpToolsListChangedNotificationDataParams {+ _toolsMcpToolsListChangedNotificationDataParams = RawJsonByteString "[]" } -- | ---data McpToolListChangedNotificationData =- McpToolListChangedNotificationData {- _methodMcpToolListChangedNotificationData :: String- , _paramsMcpToolListChangedNotificationData :: McpToolListChangedNotificationDataParams+data McpToolsListChangedNotificationData =+ McpToolsListChangedNotificationData {+ _methodMcpToolsListChangedNotificationData :: String+ , _paramsMcpToolsListChangedNotificationData :: McpToolsListChangedNotificationDataParams } deriving (Show, Read, Eq) -$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpToolListChangedNotificationData", omitNothingFields = True} ''McpToolListChangedNotificationData)-makeLenses ''McpToolListChangedNotificationData+$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpToolsListChangedNotificationData", omitNothingFields = True} ''McpToolsListChangedNotificationData)+makeLenses ''McpToolsListChangedNotificationData -instance Default McpToolListChangedNotificationData where- def = McpToolListChangedNotificationData {- _methodMcpToolListChangedNotificationData = "notifications/tools/list_changed"- , _paramsMcpToolListChangedNotificationData = def+instance Default McpToolsListChangedNotificationData where+ def = McpToolsListChangedNotificationData {+ _methodMcpToolsListChangedNotificationData = "notifications/tools/list_changed"+ , _paramsMcpToolsListChangedNotificationData = def }+ -- | --+data McpPromptsListChangedNotificationDataParams =+ McpPromptsListChangedNotificationDataParams {+ _promptsMcpPromptsListChangedNotificationDataParams :: RawJsonByteString+ } deriving (Show, Read, Eq)++$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpPromptsListChangedNotificationDataParams", omitNothingFields = True} ''McpPromptsListChangedNotificationDataParams)+makeLenses ''McpPromptsListChangedNotificationDataParams++instance Default McpPromptsListChangedNotificationDataParams where+ def = McpPromptsListChangedNotificationDataParams {+ _promptsMcpPromptsListChangedNotificationDataParams = RawJsonByteString "[]"+ }++-- |+--+data McpPromptsListChangedNotificationData =+ McpPromptsListChangedNotificationData {+ _methodMcpPromptsListChangedNotificationData :: String+ , _paramsMcpPromptsListChangedNotificationData :: McpPromptsListChangedNotificationDataParams+ } deriving (Show, Read, Eq)++$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpPromptsListChangedNotificationData", omitNothingFields = True} ''McpPromptsListChangedNotificationData)+makeLenses ''McpPromptsListChangedNotificationData++instance Default McpPromptsListChangedNotificationData where+ def = McpPromptsListChangedNotificationData {+ _methodMcpPromptsListChangedNotificationData = "notifications/prompts/list_changed"+ , _paramsMcpPromptsListChangedNotificationData = def+ }++-- |+-- data McpNotification =- McpToolListChangedNotification McpToolListChangedNotificationData+ McpToolsListChangedNotification McpToolsListChangedNotificationData+ | McpPromptsListChangedNotification McpPromptsListChangedNotificationData deriving (Show, Read, Eq) -------------------------------------------------------------------------------- -- | ---type PtyConnectCommandCallback a = ExitCode- -> String -- ^ stdout- -> String -- ^ stderr- -> IO a+type ToolsCallCommandCallback a = ExitCode+ -> String -- ^ stdout+ -> String -- ^ stderr+ -> IO a -- | --@@ -515,25 +818,17 @@ PtyConnectCommandData { _namePtyConnectCommandData :: String , _argumentsPtyConnectCommandData :: RawJsonByteString- , _callbackPtyConnectCommandData :: PtyConnectCommandCallback ()+ , _callbackPtyConnectCommandData :: ToolsCallCommandCallback () } makeLenses ''PtyConnectCommandData --- |----type PtyTerminateCommandCallback a = ExitCode- -> String -- ^ stdout- -> String -- ^ stderr- -> IO a -- | -- data PtyTerminateCommandData = PtyTerminateCommandData {- _namePtyTerminateCommandData :: String- , _argumentsPtyTerminateCommandData :: RawJsonByteString- , _callbackPtyTerminateCommandData :: PtyTerminateCommandCallback ()+ _callbackPtyTerminateCommandData :: ToolsCallCommandCallback () } makeLenses ''PtyTerminateCommandData@@ -541,18 +836,10 @@ -- | ---type PtyMessageCommandCallback a = ExitCode- -> String -- ^ stdout- -> String -- ^ stderr- -> IO a---- |--- data PtyMessageCommandData = PtyMessageCommandData {- _namePtyMessageCommandData :: String- , _argumentsPtyMessageCommandData :: RawJsonByteString- , _callbackPtyMessageCommandData :: PtyMessageCommandCallback ()+ _argumentsPtyMessageCommandData :: RawJsonByteString+ , _callbackPtyMessageCommandData :: ToolsCallCommandCallback () } makeLenses ''PtyMessageCommandData@@ -560,36 +847,6 @@ -- | ---type SystemCommandCallback a = ExitCode- -> String -- ^ stdout- -> String -- ^ stderr- -> IO a---- |----data SystemCommandData =- SystemCommandData {- _nameSystemCommandData :: String- , _argumentsSystemCommandData :: RawJsonByteString- , _callbackSystemCommandData :: SystemCommandCallback ()- }--makeLenses ''SystemCommandData--{---- |----data CmdRunCommandData =- CmdRunCommandData {- _jsonrpcCmdRunCommandData :: JsonRpcRequest- , _nameCmdRunCommandData :: String- , _argumentsCmdRunCommandData :: RawJsonByteString- }--makeLenses ''CmdRunCommandData--}--- |--- type EchoCommandCallback a = String -> IO a -- |@@ -609,8 +866,6 @@ | PtyConnectCommand PtyConnectCommandData | PtyTerminateCommand PtyTerminateCommandData | PtyMessageCommand PtyMessageCommandData- | SystemCommand SystemCommandData--- | CmdRunCommand CmdRunCommandData --------------------------------------------------------------------------------@@ -645,44 +900,119 @@ -------------------------------------------------------------------------------- -- | --+data EchoWatchCommandData =+ EchoWatchCommandData {+ _jsonrpcEchoWatchCommandData :: JsonRpcRequest+ , _valueEchoWatchCommandData :: String+ } deriving (Show, Read, Eq)++makeLenses ''EchoWatchCommandData++-- |+-- data ToolsListWatchCommandData = ToolsListWatchCommandData {- -- _jsonrpcToolsListWatchCommandData :: JsonRpcRequest } deriving (Show, Read, Eq) makeLenses ''ToolsListWatchCommandData -- | ---data EchoWatchCommandData =- EchoWatchCommandData {- _jsonrpcEchoWatchCommandData :: JsonRpcRequest- , _valueEchoWatchCommandData :: String+data PromptsListWatchCommandData =+ PromptsListWatchCommandData { } deriving (Show, Read, Eq) -makeLenses ''EchoWatchCommandData+makeLenses ''PromptsListWatchCommandData + -- | -- data WatchCommand = EchoWatchCommand EchoWatchCommandData | ToolsListWatchCommand ToolsListWatchCommandData+ | PromptsListWatchCommand PromptsListWatchCommandData deriving (Show, Read, Eq) ++ --------------------------------------------------------------------------------+ -- | --+data ProcEchoCommandData =+ ProcEchoCommandData {+ _jsonrpcProcEchoCommandData :: JsonRpcRequest+ , _valueProcEchoCommandData :: String+ } deriving (Show, Read, Eq)++makeLenses ''ProcEchoCommandData++-- |+--+data ProcRunCommandData =+ ProcRunCommandData {+ _jsonrpcProcRunCommandData :: JsonRpcRequest+ , _nameProcRunCommandData :: String+ , _argumentsProcRunCommandData :: RawJsonByteString+ } deriving (Show, Read, Eq)++makeLenses ''ProcRunCommandData+++-- |+--+data ProcTerminateCommandData =+ ProcTerminateCommandData {+ _jsonrpcProcTerminateCommandData :: JsonRpcRequest+ } deriving (Show, Read, Eq)+ +makeLenses ''ProcTerminateCommandData+++-- |+--+data ProcMessageCommandData =+ ProcMessageCommandData {+ _jsonrpcProcMessageCommandData :: JsonRpcRequest+ , _argumentsProcMessageCommandData :: RawJsonByteString+ } deriving (Show, Read, Eq)++makeLenses ''ProcMessageCommandData++-- |+--+data ProcSpawnCommand =+ ProcEchoCommand ProcEchoCommandData+ | ProcRunCommand ProcRunCommandData+ | ProcTerminateCommand ProcTerminateCommandData+ | ProcMessageCommand ProcMessageCommandData+ deriving (Show, Read, Eq)++-- |+--+getJsonRpcProcSpawnCommand :: ProcSpawnCommand -> JsonRpcRequest+getJsonRpcProcSpawnCommand (ProcEchoCommand d) = d^.jsonrpcProcEchoCommandData+getJsonRpcProcSpawnCommand (ProcRunCommand d) = d^.jsonrpcProcRunCommandData+getJsonRpcProcSpawnCommand (ProcTerminateCommand d) = d^.jsonrpcProcTerminateCommandData+getJsonRpcProcSpawnCommand (ProcMessageCommand d) = d^.jsonrpcProcMessageCommandData++--------------------------------------------------------------------------------+-- |+-- data DomainData = DomainData {- _logDirDomainData :: Maybe String- , _logLevelDomainData :: LogLevel- , _toolsDirDomainData :: String- , _requestQueueDomainData :: TQueue McpRequest- , _responseQueueDomainData :: TQueue McpResponse+ _logDirDomainData :: Maybe String+ , _logLevelDomainData :: LogLevel+ , _toolsDirDomainData :: String+ , _promptsDirDomainData :: String+ , _resourcesDirDomainData :: String+ , _requestQueueDomainData :: TQueue McpRequest+ , _responseQueueDomainData :: TQueue McpResponse , _notificationQueueDomainData :: TQueue McpNotification- , _commandQueueDomainData :: TQueue Command- , _cmdRunQueueDomainData :: TQueue CmdRunCommand- , _watchQueueDomainData :: TQueue WatchCommand- , _promptsDomainData :: [String]+ , _commandQueueDomainData :: TQueue Command+ , _cmdRunQueueDomainData :: TQueue CmdRunCommand+ , _watchQueueDomainData :: TQueue WatchCommand+ , _procspawnQueueDomainData :: TQueue ProcSpawnCommand+ , _promptsDomainData :: [String] } makeLenses ''DomainData@@ -704,16 +1034,20 @@ cmdQ <- newTQueueIO cmdRunQ <- newTQueueIO watchQ <- newTQueueIO+ procQ <- newTQueueIO return DomainData { _logDirDomainData = Nothing , _logLevelDomainData = LevelDebug , _toolsDirDomainData = "./tools"+ , _promptsDirDomainData = "./prompts"+ , _resourcesDirDomainData = "./resources" , _requestQueueDomainData = reqQ , _responseQueueDomainData = resQ , _notificationQueueDomainData = notQ , _commandQueueDomainData = cmdQ , _cmdRunQueueDomainData = cmdRunQ , _watchQueueDomainData = watchQ+ , _procspawnQueueDomainData = procQ , _promptsDomainData = def }
src/PMS/Domain/Model/DS/Utility.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE CPP #-} module PMS.Domain.Model.DS.Utility where @@ -9,6 +11,16 @@ import qualified Data.ByteString.Lazy as BSL import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TLE+import qualified Control.Exception.Safe as E+import qualified Data.Text as T+import Data.Char +import Control.Monad+import qualified Data.Text.Encoding as TE+import qualified Data.ByteString.Char8 as BS+import qualified Data.String.AnsiEscapeCodes.Strip.Text as ANSI+import qualified Data.Text.Encoding.Error as TEE+import qualified Control.Concurrent.STM as STM+import System.IO import PMS.Domain.Model.DM.Type import PMS.Domain.Model.DM.Constant@@ -62,3 +74,157 @@ lbs2str :: BSL.ByteString -> String lbs2str = TL.unpack. TLE.decodeUtf8 ++-- |+-- [ ";", "&&", "|", "$", "`", "<", ">", "\\", "\"", "..", "/"]+--+invalidChars :: [T.Text]+invalidChars =+#ifdef mingw32_HOST_OS+ [ "&&", "||", "|", ".."]+#else+ [ "&&", "||", "|", "..", "/"]+#endif++-- |+--+invalidCmds :: [String]+invalidCmds = +#ifdef mingw32_HOST_OS+ [+ "del", "erase", "rd", "rmdir", "format"+ , "shutdown", "restart", "taskkill"+ ]+#else+ [+ "rm", "mv", "dd", "chmod", "chown"+ , "shutdown", "reboot", "kill", "nc"+ ]+#endif++-- |+--+validateCommand :: String -> IO String+validateCommand cmd = do+ let tcmd = T.pack cmd++ when (null cmd) $+ E.throwString "Command is empty."++ mapM_ (\seqStr ->+ when (seqStr `T.isInfixOf` tcmd) $+ E.throwString $ "Command contains forbidden sequence: " ++ T.unpack seqStr+ ) invalidChars++ when (cmd `elem` invalidCmds) $+ E.throwString $ "Command is forbidden: " ++ cmd++ when (any (not . isAllowedChar) cmd) $+ E.throwString $ "Command contains disallowed characters: " ++ cmd++ return cmd+ where+ isAllowedChar :: Char -> Bool+ isAllowedChar c = isAlphaNum c || c `elem` ("-._" :: String)++-- |+--+validateArg :: String -> IO String+validateArg arg = do+ let tArg = T.pack arg+ when (any (`T.isInfixOf` tArg) invalidChars) $+ E.throwString $ "Argument contains forbidden sequences: " ++ arg+ return arg++-- |+--+validateArgs :: [String] -> IO [String]+validateArgs = mapM validateArg++-- |+--+validateMessage :: String -> IO String+validateMessage cmd =+ case words cmd of+ [] -> E.throwString "Command is empty."+ (c : args) -> do+ _ <- validateCommand c+ _ <- validateArgs args+ return cmd+++-- |+--+expect :: STM.TMVar () -> IO BS.ByteString -> [String] -> IO (Maybe String)+expect lock feed prompts = STM.atomically (STM.tryTakeTMVar lock) >>= \case+ Nothing -> do+ hPutStrLn stderr "[INFO] expect running. skip."+ return Nothing+ Just () -> flip E.catchAny exception $ flip E.finally finalize $ do+ hPutStrLn stderr $ "[INFO] expect: " ++ show prompts+ output <- readUntilPrompt feed prompts+ + -- let result = T.unpack (TE.decodeUtf8 output)+ let result = T.unpack $ ANSI.stripAnsiEscapeCodes $ TE.decodeUtf8With TEE.lenientDecode output+ return (Just result)++ where+ -- |+ --+ exception :: E.SomeException -> IO (Maybe String)+ exception e = do+ hPutStrLn stderr $ "[ERROR] expect exception: " ++ show e+ return . Just . show $ e++ -- |+ --+ finalize :: IO ()+ finalize = STM.atomically $ STM.putTMVar lock ()++-- |+--+readUntilPrompt :: IO BS.ByteString -> [String] -> IO BS.ByteString+readUntilPrompt feed prompts = go BS.empty+ where+ promptBsList = map BS.pack prompts++ foundPrompt acc = any (`BS.isInfixOf` acc) promptBsList++ go acc = do+ chunk <- feed+ when ("\ESC[6n" `BS.isInfixOf` chunk) $ do+ E.throwString "Unsupported: Detected cursor position report request (ESC[6n)."++ let txt = ANSI.stripAnsiEscapeCodes $ TE.decodeUtf8With TEE.lenientDecode chunk+ hPutStrLn stderr $ "[INFO] chunk:\n" ++ T.unpack txt++ let acc' = BS.append acc chunk+ if foundPrompt acc'+ then return acc'+ else go acc'+++{-+readUntilPrompt :: Pty -> [String] -> IO BS.ByteString+readUntilPrompt pms prompts = go BS.empty T.empty+ where+ promptTextList = map T.pack prompts++ foundPrompt :: T.Text -> Bool+ foundPrompt txt = any (`T.isInfixOf` txt) promptTextList++ go accBs accTxt = do+ chunk <- readPty pms+ let txt = ANSI.stripAnsiEscapeCodes $ TE.decodeUtf8With TEE.lenientDecode chunk+ hPutStrLn stderr $ "[INFO] chunk:\n" ++ T.unpack txt++ when ("\ESC[6n" `BS.isInfixOf` chunk) $ do+ hPutStrLn stderr "[INFO] Detected cursor position report request, replying with ESC[1;1R"+ writePty pms (DBS.pack ([0x1B :: Word8, 0x5B :: Word8] ++ map (fromIntegral . ord) "0;0R"))++ let accBs' = BS.append accBs chunk+ accTxt' = T.append accTxt txt+ if foundPrompt accTxt'+ then return accBs'+ else go accBs' accTxt'+-}