diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for pms-domain-model +## 0.0.5.0 -- 2025-07-06 + +* Added socket tool. + ## 0.0.4.0 -- 2025-06-29 * Added prompts interface. diff --git a/pms-domain-model.cabal b/pms-domain-model.cabal --- a/pms-domain-model.cabal +++ b/pms-domain-model.cabal @@ -20,7 +20,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.0.4.0 +version: 0.0.5.0 -- A short (one-line) description of the package. synopsis: pms-domain-model diff --git a/src/PMS/Domain/Model/DM/Constant.hs b/src/PMS/Domain/Model/DM/Constant.hs --- a/src/PMS/Domain/Model/DM/Constant.hs +++ b/src/PMS/Domain/Model/DM/Constant.hs @@ -17,6 +17,11 @@ -- | -- +_TIMEOUT_MICROSEC :: Int +_TIMEOUT_MICROSEC = 30 * 1000 * 1000 + +-- | +-- _TOOLS_LIST_FILE :: String _TOOLS_LIST_FILE = "tools-list.json" @@ -25,9 +30,23 @@ _PROMPTS_LIST_FILE :: String _PROMPTS_LIST_FILE = "prompts-list.json" +-- | +-- +_RESOURCES_LIST_FILE :: String +_RESOURCES_LIST_FILE = "resources-list.json" -- | -- +_RESOURCES_TPL_LIST_FILE :: String +_RESOURCES_TPL_LIST_FILE = "resources-templates-list.json" + +-- | +-- _LF :: String _LF = "\n" + +-- | +-- +_CRLF :: String +_CRLF = "\r\n" diff --git a/src/PMS/Domain/Model/DM/Type.hs b/src/PMS/Domain/Model/DM/Type.hs --- a/src/PMS/Domain/Model/DM/Type.hs +++ b/src/PMS/Domain/Model/DM/Type.hs @@ -240,10 +240,112 @@ _jsonrpcMcpPromptsListRequestData = 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 McpResourcesTemplatesListRequestData = + McpResourcesTemplatesListRequestData { + _jsonrpcMcpResourcesTemplatesListRequestData :: JsonRpcRequest + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpResourcesTemplatesListRequestData", omitNothingFields = True} ''McpResourcesTemplatesListRequestData) +makeLenses ''McpResourcesTemplatesListRequestData + +instance Default McpResourcesTemplatesListRequestData where + def = McpResourcesTemplatesListRequestData { + _jsonrpcMcpResourcesTemplatesListRequestData = def + } + + +-- | +-- +data McpResourcesListRequestData = + McpResourcesListRequestData { + _jsonrpcMcpResourcesListRequestData :: JsonRpcRequest + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpResourcesListRequestData", omitNothingFields = True} ''McpResourcesListRequestData) +makeLenses ''McpResourcesListRequestData + +instance Default McpResourcesListRequestData where + def = McpResourcesListRequestData { + _jsonrpcMcpResourcesListRequestData = def + } + +-- | +-- +data McpResourcesReadRequestDataParams = + McpResourcesReadRequestDataParams { + _uriMcpResourcesReadRequestDataParams :: String + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpResourcesReadRequestDataParams", omitNothingFields = True} ''McpResourcesReadRequestDataParams) +makeLenses ''McpResourcesReadRequestDataParams + +instance Default McpResourcesReadRequestDataParams where + def = McpResourcesReadRequestDataParams { + _uriMcpResourcesReadRequestDataParams = def + } + +-- | +-- +data McpResourcesReadRequestData = + McpResourcesReadRequestData { + _jsonrpcMcpResourcesReadRequestData :: JsonRpcRequest + , _paramsMcpResourcesReadRequestData :: McpResourcesReadRequestDataParams + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpResourcesReadRequestData", omitNothingFields = True} ''McpResourcesReadRequestData) +makeLenses ''McpResourcesReadRequestData + +instance Default McpResourcesReadRequestData where + def = McpResourcesReadRequestData { + _jsonrpcMcpResourcesReadRequestData = def + , _paramsMcpResourcesReadRequestData = def + } + + + + +-- | +-- data McpInitializedNotificationData = McpInitializedNotificationData { _jsonrpcMcpInitializedNotificationData :: JsonRpcRequest @@ -331,50 +433,18 @@ -- | -- -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 | McpToolsListRequest McpToolsListRequestData | McpToolsCallRequest McpToolsCallRequestData | McpPromptsListRequest McpPromptsListRequestData + | McpPromptsGetRequest McpPromptsGetRequestData + | McpResourcesTemplatesListRequest McpResourcesTemplatesListRequestData + | McpResourcesListRequest McpResourcesListRequestData + | McpResourcesReadRequest McpResourcesReadRequestData | McpInitializedNotification McpInitializedNotificationData | McpCancelledNotification McpCancelledNotificationData | McpCompletionCompleteRequest McpCompletionCompleteRequestData - | McpPromptsGetRequest McpPromptsGetRequestData deriving (Show, Read, Eq) -------------------------------------------------------------------------------- @@ -390,7 +460,7 @@ instance Default McpInitializeResponseResultCapabilitiesResources where def = McpInitializeResponseResultCapabilitiesResources { - _subscribedMcpInitializeResponseResultCapabilitiesResources = True + _subscribedMcpInitializeResponseResultCapabilitiesResources = False , _listChangedMcpInitializeResponseResultCapabilitiesResources = True } @@ -427,7 +497,7 @@ McpInitializeResponseResultCapabilities { _toolsMcpInitializeResponseResultCapabilities :: McpInitializeResponseResultCapabilitiesTools , _promptsMcpInitializeResponseResultCapabilities :: McpInitializeResponseResultCapabilitiesPrompts - -- , _resourcesMcpInitializeResponseResultCapabilities :: McpInitializeResponseResultCapabilitiesResources + , _resourcesMcpInitializeResponseResultCapabilities :: McpInitializeResponseResultCapabilitiesResources } deriving (Show, Read, Eq) $(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpInitializeResponseResultCapabilities", omitNothingFields = True} ''McpInitializeResponseResultCapabilities) makeLenses ''McpInitializeResponseResultCapabilities @@ -436,7 +506,7 @@ def = McpInitializeResponseResultCapabilities { _toolsMcpInitializeResponseResultCapabilities = def , _promptsMcpInitializeResponseResultCapabilities = def - -- , _resourcesMcpInitializeResponseResultCapabilities = def + , _resourcesMcpInitializeResponseResultCapabilities = def } -- | @@ -451,8 +521,8 @@ instance Default McpInitializeResponseResultServerInfo where def = McpInitializeResponseResultServerInfo { - _nameMcpInitializeResponseResultServerInfo = def - , _versionMcpInitializeResponseResultServerInfo = def + _nameMcpInitializeResponseResultServerInfo = "pty-mcp-server" + , _versionMcpInitializeResponseResultServerInfo = "0.0.4" } -- | @@ -470,7 +540,7 @@ instance Default McpInitializeResponseResult where def = McpInitializeResponseResult { - _protocolVersionMcpInitializeResponseResult = def + _protocolVersionMcpInitializeResponseResult = "2024-11-05" , _capabilitiesMcpInitializeResponseResult = def , _serverInfoMcpInitializeResponseResult = def , _instructionsMcpInitializeResponseResult = def @@ -616,11 +686,166 @@ , _resultMcpPromptsListResponseData = 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 McpResourcesTemplatesListResponseResult = + McpResourcesTemplatesListResponseResult { + _resourcesMcpResourcesTemplatesListResponseResult :: RawJsonByteString + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpResourcesTemplatesListResponseResult", omitNothingFields = True} ''McpResourcesTemplatesListResponseResult) +makeLenses ''McpResourcesTemplatesListResponseResult + +instance Default McpResourcesTemplatesListResponseResult where + def = McpResourcesTemplatesListResponseResult { + _resourcesMcpResourcesTemplatesListResponseResult = def + } + +-- | +-- +data McpResourcesTemplatesListResponseData = + McpResourcesTemplatesListResponseData { + _jsonrpcMcpResourcesTemplatesListResponseData :: JsonRpcRequest + , _resultMcpResourcesTemplatesListResponseData :: McpResourcesTemplatesListResponseResult + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpResourcesTemplatesListResponseData", omitNothingFields = True} ''McpResourcesTemplatesListResponseData) +makeLenses ''McpResourcesTemplatesListResponseData + +instance Default McpResourcesTemplatesListResponseData where + def = McpResourcesTemplatesListResponseData { + _jsonrpcMcpResourcesTemplatesListResponseData = def + , _resultMcpResourcesTemplatesListResponseData = def + } + + + +-- | +-- +data McpResourcesListResponseResult = + McpResourcesListResponseResult { + _resourcesMcpResourcesListResponseResult :: RawJsonByteString + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpResourcesListResponseResult", omitNothingFields = True} ''McpResourcesListResponseResult) +makeLenses ''McpResourcesListResponseResult + +instance Default McpResourcesListResponseResult where + def = McpResourcesListResponseResult { + _resourcesMcpResourcesListResponseResult = def + } + +-- | +-- +data McpResourcesListResponseData = + McpResourcesListResponseData { + _jsonrpcMcpResourcesListResponseData :: JsonRpcRequest + , _resultMcpResourcesListResponseData :: McpResourcesListResponseResult + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpResourcesListResponseData", omitNothingFields = True} ''McpResourcesListResponseData) +makeLenses ''McpResourcesListResponseData + +instance Default McpResourcesListResponseData where + def = McpResourcesListResponseData { + _jsonrpcMcpResourcesListResponseData = def + , _resultMcpResourcesListResponseData = def + } + + + + + +-- | +-- +data McpResourcesReadResponseResult = + McpResourcesReadResponseResult { + _contentsMcpResourcesReadResponseResult :: [RawJsonByteString] + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpResourcesReadResponseResult", omitNothingFields = True} ''McpResourcesReadResponseResult) +makeLenses ''McpResourcesReadResponseResult + +instance Default McpResourcesReadResponseResult where + def = McpResourcesReadResponseResult { + _contentsMcpResourcesReadResponseResult = def + } + +-- | +-- +data McpResourcesReadResponseData = + McpResourcesReadResponseData { + _jsonrpcMcpResourcesReadResponseData :: JsonRpcRequest + , _resultMcpResourcesReadResponseData :: McpResourcesReadResponseResult + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpResourcesReadResponseData", omitNothingFields = True} ''McpResourcesReadResponseData) +makeLenses ''McpResourcesReadResponseData + +instance Default McpResourcesReadResponseData where + def = McpResourcesReadResponseData { + _jsonrpcMcpResourcesReadResponseData = def + , _resultMcpResourcesReadResponseData = def + } + + + + +-- | +-- data McpCompleteResponseResult = McpCompleteResponseResult { _valuesMcpCompleteResponseResult :: [String] @@ -671,64 +896,54 @@ -- | -- -data McpPromptsGetResponseResultPromptMessage = - McpPromptsGetResponseResultPromptMessage { - _roleMcpPromptsGetResponseResultPromptMessage :: String - , _contentMcpPromptsGetResponseResultPromptMessage :: RawJsonByteString +data TextResourceContents = + TextResourceContents { + _uriTextResourceContents :: String + , _mimeTypeTextResourceContents :: Maybe String + , _textTextResourceContents :: String } deriving (Show, Read, Eq) -$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpPromptsGetResponseResultPromptMessage", omitNothingFields = True} ''McpPromptsGetResponseResultPromptMessage) -makeLenses ''McpPromptsGetResponseResultPromptMessage +$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "TextResourceContents", omitNothingFields = True} ''TextResourceContents) +makeLenses ''TextResourceContents -instance Default McpPromptsGetResponseResultPromptMessage where - def = McpPromptsGetResponseResultPromptMessage { - _roleMcpPromptsGetResponseResultPromptMessage = "assistant" - , _contentMcpPromptsGetResponseResultPromptMessage = def +instance Default TextResourceContents where + def = TextResourceContents { + _uriTextResourceContents = def + , _mimeTypeTextResourceContents = def + , _textTextResourceContents = def } - -- | -- -data McpPromptsGetResponseResult = - McpPromptsGetResponseResult { - _messagesMcpPromptsGetResponseResult :: [McpPromptsGetResponseResultPromptMessage] +data BlobResourceContents = + BlobResourceContents { + _uriBlobResourceContents :: String + , _mimeTypeBlobResourceContents :: Maybe String + , _blobResourceContents :: String } deriving (Show, Read, Eq) -$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpPromptsGetResponseResult", omitNothingFields = True} ''McpPromptsGetResponseResult) -makeLenses ''McpPromptsGetResponseResult +$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "BlobResourceContents", omitNothingFields = True} ''BlobResourceContents) +makeLenses ''BlobResourceContents -instance Default McpPromptsGetResponseResult where - def = McpPromptsGetResponseResult { - _messagesMcpPromptsGetResponseResult = def +instance Default BlobResourceContents where + def = BlobResourceContents { + _uriBlobResourceContents = def + , _mimeTypeBlobResourceContents = def + , _blobResourceContents = 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 + | McpResourcesTemplatesListResponse McpResourcesTemplatesListResponseData + | McpResourcesListResponse McpResourcesListResponseData + | McpResourcesReadResponse McpResourcesReadResponseData + | McpCompleteResponse McpCompleteResponseData deriving (Show, Read, Eq) -------------------------------------------------------------------------------- @@ -769,7 +984,7 @@ -- data McpPromptsListChangedNotificationDataParams = McpPromptsListChangedNotificationDataParams { - _promptsMcpPromptsListChangedNotificationDataParams :: RawJsonByteString + _promptsMcpPromptsListChangedNotificationDataParams :: RawJsonByteString -- prompts-list } deriving (Show, Read, Eq) $(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpPromptsListChangedNotificationDataParams", omitNothingFields = True} ''McpPromptsListChangedNotificationDataParams) @@ -777,7 +992,7 @@ instance Default McpPromptsListChangedNotificationDataParams where def = McpPromptsListChangedNotificationDataParams { - _promptsMcpPromptsListChangedNotificationDataParams = RawJsonByteString "[]" + _promptsMcpPromptsListChangedNotificationDataParams = RawJsonByteString "[]" -- prompts-list } -- | @@ -797,11 +1012,47 @@ , _paramsMcpPromptsListChangedNotificationData = def } + + + -- | -- +data McpResourcesListChangedNotificationDataParams = + McpResourcesListChangedNotificationDataParams { + _resourcesMcpResourcesListChangedNotificationDataParams :: RawJsonByteString -- resources-list + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpResourcesListChangedNotificationDataParams", omitNothingFields = True} ''McpResourcesListChangedNotificationDataParams) +makeLenses ''McpResourcesListChangedNotificationDataParams + +instance Default McpResourcesListChangedNotificationDataParams where + def = McpResourcesListChangedNotificationDataParams { + _resourcesMcpResourcesListChangedNotificationDataParams = RawJsonByteString "[]" -- resources-list + } + +-- | +-- +data McpResourcesListChangedNotificationData = + McpResourcesListChangedNotificationData { + _methodMcpResourcesListChangedNotificationData :: String + , _paramsMcpResourcesListChangedNotificationData :: McpResourcesListChangedNotificationDataParams + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "McpResourcesListChangedNotificationData", omitNothingFields = True} ''McpResourcesListChangedNotificationData) +makeLenses ''McpResourcesListChangedNotificationData + +instance Default McpResourcesListChangedNotificationData where + def = McpResourcesListChangedNotificationData { + _methodMcpResourcesListChangedNotificationData = "notifications/resources/list_changed" + , _paramsMcpResourcesListChangedNotificationData = def + } + +-- | +-- data McpNotification = McpToolsListChangedNotification McpToolsListChangedNotificationData | McpPromptsListChangedNotification McpPromptsListChangedNotificationData + | McpResourcesListChangedNotification McpResourcesListChangedNotificationData deriving (Show, Read, Eq) -------------------------------------------------------------------------------- @@ -924,19 +1175,27 @@ makeLenses ''PromptsListWatchCommandData +-- | +-- +data ResourcesListWatchCommandData = + ResourcesListWatchCommandData { + } deriving (Show, Read, Eq) +makeLenses ''ResourcesListWatchCommandData + + -- | -- data WatchCommand = EchoWatchCommand EchoWatchCommandData | ToolsListWatchCommand ToolsListWatchCommandData | PromptsListWatchCommand PromptsListWatchCommandData + | ResourcesListWatchCommand ResourcesListWatchCommandData deriving (Show, Read, Eq) -------------------------------------------------------------------------------- - -- | -- data ProcEchoCommandData = @@ -996,9 +1255,107 @@ getJsonRpcProcSpawnCommand (ProcTerminateCommand d) = d^.jsonrpcProcTerminateCommandData getJsonRpcProcSpawnCommand (ProcMessageCommand d) = d^.jsonrpcProcMessageCommandData + -------------------------------------------------------------------------------- -- | -- +data SocketEchoCommandData = + SocketEchoCommandData { + _jsonrpcSocketEchoCommandData :: JsonRpcRequest + , _valueSocketEchoCommandData :: String + } deriving (Show, Read, Eq) + +makeLenses ''SocketEchoCommandData + +-- | +-- +data SocketOpenCommandData = + SocketOpenCommandData { + _jsonrpcSocketOpenCommandData :: JsonRpcRequest + , _nameSocketOpenCommandData :: String + , _argumentsSocketOpenCommandData :: RawJsonByteString + } deriving (Show, Read, Eq) + +makeLenses ''SocketOpenCommandData + + +-- | +-- +data SocketTelnetCommandData = + SocketTelnetCommandData { + _jsonrpcSocketTelnetCommandData :: JsonRpcRequest + , _nameSocketTelnetCommandData :: String + , _argumentsSocketTelnetCommandData :: RawJsonByteString + } deriving (Show, Read, Eq) + +makeLenses ''SocketTelnetCommandData + +-- | +-- +data SocketCloseCommandData = + SocketCloseCommandData { + _jsonrpcSocketCloseCommandData :: JsonRpcRequest + } deriving (Show, Read, Eq) + +makeLenses ''SocketCloseCommandData + + +-- | +-- +data SocketReadCommandData = + SocketReadCommandData { + _jsonrpcSocketReadCommandData :: JsonRpcRequest + , _argumentsSocketReadCommandData :: RawJsonByteString + } deriving (Show, Read, Eq) + +makeLenses ''SocketReadCommandData + +-- | +-- +data SocketWriteCommandData = + SocketWriteCommandData { + _jsonrpcSocketWriteCommandData :: JsonRpcRequest + , _argumentsSocketWriteCommandData :: RawJsonByteString + } deriving (Show, Read, Eq) + +makeLenses ''SocketWriteCommandData + + +-- | +-- +data SocketMessageCommandData = + SocketMessageCommandData { + _jsonrpcSocketMessageCommandData :: JsonRpcRequest + , _argumentsSocketMessageCommandData :: RawJsonByteString + } deriving (Show, Read, Eq) + +makeLenses ''SocketMessageCommandData + +-- | +-- +data SocketCommand = + SocketEchoCommand SocketEchoCommandData + | SocketOpenCommand SocketOpenCommandData + | SocketCloseCommand SocketCloseCommandData + | SocketReadCommand SocketReadCommandData + | SocketWriteCommand SocketWriteCommandData + | SocketMessageCommand SocketMessageCommandData + | SocketTelnetCommand SocketTelnetCommandData + deriving (Show, Read, Eq) + +-- | +-- +{- +getJsonRpcSocketCommand :: SocketCommand -> JsonRpcRequest +getJsonRpcSocketCommand (SocketEchoCommand d) = d^.jsonrpcSocketEchoCommandData +getJsonRpcSocketCommand (SocketOpenCommand d) = d^.jsonrpcSocketOpenCommandData +getJsonRpcSocketCommand (SocketCloseCommand d) = d^.jsonrpcSocketCloseCommandData +getJsonRpcSocketCommand (SocketMessageCommand d) = d^.jsonrpcSocketMessageCommandData +-} + +-------------------------------------------------------------------------------- +-- | +-- data DomainData = DomainData { _logDirDomainData :: Maybe String , _logLevelDomainData :: LogLevel @@ -1012,6 +1369,7 @@ , _cmdRunQueueDomainData :: TQueue CmdRunCommand , _watchQueueDomainData :: TQueue WatchCommand , _procspawnQueueDomainData :: TQueue ProcSpawnCommand + , _socketQueueDomainData :: TQueue SocketCommand , _promptsDomainData :: [String] } @@ -1035,20 +1393,22 @@ cmdRunQ <- newTQueueIO watchQ <- newTQueueIO procQ <- newTQueueIO + socketQ <- newTQueueIO return DomainData { - _logDirDomainData = Nothing - , _logLevelDomainData = LevelDebug - , _toolsDirDomainData = "./tools" - , _promptsDirDomainData = "./prompts" - , _resourcesDirDomainData = "./resources" - , _requestQueueDomainData = reqQ - , _responseQueueDomainData = resQ + _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 + , _commandQueueDomainData = cmdQ + , _cmdRunQueueDomainData = cmdRunQ + , _watchQueueDomainData = watchQ + , _procspawnQueueDomainData = procQ + , _socketQueueDomainData = socketQ + , _promptsDomainData = def } -- | diff --git a/src/PMS/Domain/Model/DS/Utility.hs b/src/PMS/Domain/Model/DS/Utility.hs --- a/src/PMS/Domain/Model/DS/Utility.hs +++ b/src/PMS/Domain/Model/DS/Utility.hs @@ -21,6 +21,7 @@ import qualified Data.Text.Encoding.Error as TEE import qualified Control.Concurrent.STM as STM import System.IO +import Data.List import PMS.Domain.Model.DM.Type import PMS.Domain.Model.DM.Constant @@ -186,6 +187,32 @@ readUntilPrompt :: IO BS.ByteString -> [String] -> IO BS.ByteString readUntilPrompt feed prompts = go BS.empty where + (negativePrompts, positivePrompts) = partition (\s -> not (null s) && head s == '!') prompts + promptBsList = map BS.pack $ filter (not . null) $ map (dropWhile (== '!')) positivePrompts + rejectPromptBs = map BS.pack $ map (drop 1) negativePrompts + + foundPrompt acc = + any (`BS.isInfixOf` acc) promptBsList && + all (not . (`BS.isInfixOf` acc)) rejectPromptBs + + go acc = do + chunk <- feed + when ("\ESC[6n" `BS.isInfixOf` chunk) $ + E.throwString "Unsupported: Detected cursor position report request (ESC[6n)." + + let txt = 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 :: 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 @@ -195,7 +222,8 @@ 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 + -- let txt = ANSI.stripAnsiEscapeCodes $ TE.decodeUtf8With TEE.lenientDecode chunk + let txt = TE.decodeUtf8With TEE.lenientDecode chunk hPutStrLn stderr $ "[INFO] chunk:\n" ++ T.unpack txt let acc' = BS.append acc chunk @@ -204,7 +232,7 @@ else go acc' -{- + readUntilPrompt :: Pty -> [String] -> IO BS.ByteString readUntilPrompt pms prompts = go BS.empty T.empty where