pms-domain-service 0.0.3.0 → 0.0.4.0

raw patch · 12 files changed

+386/−15 lines, 12 filesdep +network-uri

Dependencies added: network-uri

Files

• CHANGELOG.md +4/−0
• pms-domain-service.cabal +5/−1
• src/PMS/Domain/Service/DM/Type.hs +8/−2
• src/PMS/Domain/Service/DS/Core.hs +4/−1
• src/PMS/Domain/Service/DS/State/Run.hs +3/−0
• src/PMS/Domain/Service/DS/State/Run/ResourcesList.hs +64/−0
• src/PMS/Domain/Service/DS/State/Run/ResourcesRead.hs +91/−0
• src/PMS/Domain/Service/DS/State/Run/ResourcesTemplatesList.hs +64/−0
• src/PMS/Domain/Service/DS/State/Run/ToolsCall.hs +97/−1
• src/PMS/Domain/Service/DS/State/Start.hs +20/−4
• src/PMS/Domain/Service/DS/State/Start/Initialized.hs +6/−2
• src/PMS/Domain/Service/DS/State/Stop.hs +20/−4

@@ -1,5 +1,9 @@ # Revision history for pms-domain-service +## 0.0.4.0 -- 2025-07-06++* Added resources interface.+ ## 0.0.3.0 -- 2025-06-29  * Added prompts interface.

@@ -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-service@@ -70,6 +70,9 @@                       PMS.Domain.Service.DS.State.Run.ToolsCall,                       PMS.Domain.Service.DS.State.Run.PromptsList,                       PMS.Domain.Service.DS.State.Run.PromptsGet,+                      PMS.Domain.Service.DS.State.Run.ResourcesTemplatesList,+                      PMS.Domain.Service.DS.State.Run.ResourcesList,+                      PMS.Domain.Service.DS.State.Run.ResourcesRead,                       PMS.Domain.Service.DS.State.Start,                       PMS.Domain.Service.DS.State.Start.Initialize,                       PMS.Domain.Service.DS.State.Start.Initialized,@@ -100,6 +103,7 @@                       aeson,                       unordered-containers,                       mustache,+                      network-uri,                       pms-domain-model      -- Directories containing source files.

@@ -51,9 +51,12 @@ data ToolsListEventData   = ToolsListEventData DM.McpToolsListRequestData deriving (Show) data ToolsCallEventData   = ToolsCallEventData DM.McpToolsCallRequestData deriving (Show) data PromptsListEventData = PromptsListEventData DM.McpPromptsListRequestData deriving (Show)+data PromptsGetEventData  = PromptsGetEventData DM.McpPromptsGetRequestData deriving (Show)+data ResourcesTemplatesListEventData = ResourcesTemplatesListEventData DM.McpResourcesTemplatesListRequestData deriving (Show)+data ResourcesListEventData = ResourcesListEventData DM.McpResourcesListRequestData deriving (Show)+data ResourcesReadEventData = ResourcesReadEventData DM.McpResourcesReadRequestData deriving (Show) data CancelledEventData   = CancelledEventData DM.McpCancelledNotificationData deriving (Show) data CompletionCompleteEventData = CompletionCompleteEventData DM.McpCompletionCompleteRequestData deriving (Show)-data PromptsGetEventData         = PromptsGetEventData DM.McpPromptsGetRequestData deriving (Show)   -- |@@ -68,9 +71,12 @@   ToolsListEvent   :: ToolsListEventData   -> Event ToolsListEventData   ToolsCallEvent   :: ToolsCallEventData   -> Event ToolsCallEventData   PromptsListEvent :: PromptsListEventData -> Event PromptsListEventData+  PromptsGetEvent  :: PromptsGetEventData -> Event PromptsGetEventData+  ResourcesTemplatesListEvent :: ResourcesTemplatesListEventData -> Event ResourcesTemplatesListEventData+  ResourcesListEvent :: ResourcesListEventData -> Event ResourcesListEventData+  ResourcesReadEvent :: ResourcesReadEventData -> Event ResourcesReadEventData   CancelledEvent   :: CancelledEventData   -> Event CancelledEventData   CompletionCompleteEvent :: CompletionCompleteEventData -> Event CompletionCompleteEventData-  PromptsGetEvent         :: PromptsGetEventData -> Event PromptsGetEventData  deriving instance Show r => Show (Event r) 

@@ -80,10 +80,13 @@ req2ev (DM.McpToolsListRequest dat) = pure . EventW . ToolsListEvent . ToolsListEventData $ dat req2ev (DM.McpToolsCallRequest dat) = pure . EventW . ToolsCallEvent . ToolsCallEventData $ dat req2ev (DM.McpPromptsListRequest dat) = pure . EventW . PromptsListEvent . PromptsListEventData $ dat+req2ev (DM.McpPromptsGetRequest dat) = pure . EventW . PromptsGetEvent . PromptsGetEventData $ dat+req2ev (DM.McpResourcesTemplatesListRequest dat) = pure . EventW . ResourcesTemplatesListEvent . ResourcesTemplatesListEventData $ dat+req2ev (DM.McpResourcesListRequest dat) = pure . EventW . ResourcesListEvent . ResourcesListEventData $ dat+req2ev (DM.McpResourcesReadRequest dat) = pure . EventW . ResourcesReadEvent . ResourcesReadEventData $ dat req2ev (DM.McpInitializedNotification dat) = pure . EventW . InitializedEvent . InitializedEventData $ dat req2ev (DM.McpCancelledNotification dat) = pure . EventW . CancelledEvent . CancelledEventData $ dat req2ev (DM.McpCompletionCompleteRequest dat) = pure . EventW . CompletionCompleteEvent . CompletionCompleteEventData $ dat-req2ev (DM.McpPromptsGetRequest dat) = pure . EventW . PromptsGetEvent . PromptsGetEventData $ dat  --------------------------------------------------------------------------------- -- |

@@ -19,6 +19,9 @@ import PMS.Domain.Service.DS.State.Run.ToolsCall() import PMS.Domain.Service.DS.State.Run.PromptsList() import PMS.Domain.Service.DS.State.Run.PromptsGet()+import PMS.Domain.Service.DS.State.Run.ResourcesTemplatesList()+import PMS.Domain.Service.DS.State.Run.ResourcesList()+import PMS.Domain.Service.DS.State.Run.ResourcesRead()   instanceTH_IAppState ''RunStateData

@@ -0,0 +1,64 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++module PMS.Domain.Service.DS.State.Run.ResourcesList where++import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Logger+import qualified Data.Text as T+import Control.Lens+import Control.Monad.Reader+import qualified Control.Concurrent.STM as STM+import System.FilePath+import System.Directory+import Control.Monad.Except+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BL8++import qualified PMS.Domain.Model.DM.Type as DM+import qualified PMS.Domain.Model.DM.Constant as DM++import PMS.Domain.Service.DM.Type+import qualified PMS.Domain.Service.DS.Utility as U+++-- |+--+instance IStateActivity RunStateData ResourcesListEventData where+  action _ (ResourcesListEvent (ResourcesListEventData dat)) = flip catchError errHdl $ do+    $logDebugS DM._LOGTAG "Run ResourcesListEvent called."++    resourcesDir <- view DM.resourcesDirDomainData <$> lift ask++    let resourcesFile = resourcesDir </> DM._RESOURCES_LIST_FILE+    exists <- liftIO $ doesFileExist resourcesFile+    cont <- if exists+              then U.readFile resourcesFile+              else do+                $logInfoS DM._LOGTAG $ T.pack $ "file not found." ++ resourcesFile+                return "[]"++    response cont+    return noStateTransition++    where+      errHdl :: String -> AppContext (Maybe StateTransition)+      errHdl msg = do+        $logErrorS DM._LOGTAG $ T.pack $ "ResourcesListEventData: exception occurred. " ++ msg+        response $ BL8.pack msg+        return noStateTransition++      response :: BL.ByteString -> AppContext ()+      response cont = do+        let result = DM.McpResourcesListResponseResult $ DM.RawJsonByteString cont+            jsonRpc = dat^.DM.jsonrpcMcpResourcesListRequestData+            resDat = DM.McpResourcesListResponseData jsonRpc result+            res = DM.McpResourcesListResponse resDat++        $logDebugS DM._LOGTAG $ T.pack $ show res++        queue <- view DM.responseQueueDomainData <$> lift ask+        liftIO $ STM.atomically $ STM.writeTQueue queue res

@@ -0,0 +1,91 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++module PMS.Domain.Service.DS.State.Run.ResourcesRead where+++import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Logger+import Control.Lens+import Control.Monad.Reader+import qualified Control.Concurrent.STM as STM+import qualified Data.Text as T+import Data.Aeson+import Control.Monad.Except+import Data.Default+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TLE+import Network.URI+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++import PMS.Domain.Service.DM.Type+import qualified PMS.Domain.Service.DS.Utility as U+++-- |+--+instance IStateActivity RunStateData ResourcesReadEventData where+  action _ (ResourcesReadEvent (ResourcesReadEventData evDat)) = flip catchError errHdl $ do+    $logDebugS DM._LOGTAG $ T.pack $ "Run ResourcesReadEvent called." ++ show evDat++    let params = evDat^.DM.paramsMcpResourcesReadRequestData+    uri <- getURI $ params^.DM.uriMcpResourcesReadRequestDataParams++    cont <- getUriContents uri++    response $ TL.unpack $ TLE.decodeUtf8 cont+   +    return noStateTransition++    where+      errHdl :: String -> AppContext (Maybe StateTransition)+      errHdl msg = do+        $logErrorS DM._LOGTAG $ T.pack $ "ResourcesReadEventData: exception occurred. " ++ msg+        response msg+        return noStateTransition++      getURI :: String -> AppContext URI+      getURI uriStr = case parseURI uriStr of+        Nothing   -> throwError "Invalid URI, parse fail."+        Just uri  -> return uri++      response :: String -> AppContext ()+      response cont = do+        let txtDat = def {DM._textTextResourceContents = cont} +            content = encode txtDat+            result = DM.McpResourcesReadResponseResult [DM.RawJsonByteString content]+            jsonRpc = evDat^.DM.jsonrpcMcpResourcesReadRequestData+            resDat = DM.McpResourcesReadResponseData jsonRpc result+            res = DM.McpResourcesReadResponse resDat++        $logDebugS DM._LOGTAG $ T.pack $ show res++        queue <- view DM.responseQueueDomainData <$> lift ask+        liftIO $ STM.atomically $ STM.writeTQueue queue res+  +-- |+--+getUriContents :: URI -> AppContext BL.ByteString+getUriContents uri = case uriScheme uri of+  "file:" -> handleFileURI uri+  x       -> throwError $ "Unsupported scheme" ++ show x++-- |+--+handleFileURI :: URI -> AppContext BL.ByteString+handleFileURI uri = do+  resourcesDir <- view DM.resourcesDirDomainData <$> lift ask+  let resourcesFile = uriPath uri+      resourcesFilePath = resourcesDir ++ resourcesFile+      +  $logDebugS DM._LOGTAG $ T.pack $ "resourcesDir : " ++ resourcesDir+  $logDebugS DM._LOGTAG $ T.pack $ "resourcesFile : " ++ resourcesFile+  $logDebugS DM._LOGTAG $ T.pack $ "resourcesFilePath : " ++ resourcesFilePath++  U.readFile resourcesFilePath

@@ -0,0 +1,64 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++module PMS.Domain.Service.DS.State.Run.ResourcesTemplatesList where++import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Logger+import qualified Data.Text as T+import Control.Lens+import Control.Monad.Reader+import qualified Control.Concurrent.STM as STM+import System.FilePath+import System.Directory+import Control.Monad.Except+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BL8++import qualified PMS.Domain.Model.DM.Type as DM+import qualified PMS.Domain.Model.DM.Constant as DM++import PMS.Domain.Service.DM.Type+import qualified PMS.Domain.Service.DS.Utility as U+++-- |+--+instance IStateActivity RunStateData ResourcesTemplatesListEventData where+  action _ (ResourcesTemplatesListEvent (ResourcesTemplatesListEventData dat)) = flip catchError errHdl $ do+    $logDebugS DM._LOGTAG "Run ResourcesTemplatesListEvent called."++    resourcesDir <- view DM.resourcesDirDomainData <$> lift ask++    let resourcesFile = resourcesDir </> DM._RESOURCES_TPL_LIST_FILE+    exists <- liftIO $ doesFileExist resourcesFile+    cont <- if exists+              then U.readFile resourcesFile+              else do+                $logInfoS DM._LOGTAG $ T.pack $ "file not found." ++ resourcesFile+                return "[]"++    response cont+    return noStateTransition++    where+      errHdl :: String -> AppContext (Maybe StateTransition)+      errHdl msg = do+        $logErrorS DM._LOGTAG $ T.pack $ "ResourcesTemplatesListEventData: exception occurred. " ++ msg+        response $ BL8.pack msg+        return noStateTransition++      response :: BL.ByteString -> AppContext ()+      response cont = do+        let result = DM.McpResourcesTemplatesListResponseResult $ DM.RawJsonByteString cont+            jsonRpc = dat^.DM.jsonrpcMcpResourcesTemplatesListRequestData+            resDat = DM.McpResourcesTemplatesListResponseData jsonRpc result+            res = DM.McpResourcesTemplatesListResponse resDat++        $logDebugS DM._LOGTAG $ T.pack $ show res++        queue <- view DM.responseQueueDomainData <$> lift ask+        liftIO $ STM.atomically $ STM.writeTQueue queue res

@@ -14,6 +14,7 @@ import Control.Monad.Reader import qualified Control.Concurrent.STM as STM import System.Exit+import qualified Data.Text as T  import qualified PMS.Domain.Model.DM.Type as DM import qualified PMS.Domain.Model.DM.Constant as DM@@ -38,13 +39,26 @@       go dat "pty-message"    = ptyMessageCommand dat       go dat "pty-bash"       = ptyConnectCommand dat       go dat "pty-ssh"        = ptyConnectCommand dat+      go dat "pty-telnet"     = ptyConnectCommand dat       go dat "pty-cabal"      = ptyConnectCommand dat       go dat "pty-stack"      = ptyConnectCommand dat       go dat "pty-ghci"       = ptyConnectCommand dat       go dat "proc-spawn"     = procRunCommand dat+      go dat "proc-cmd"       = procRunCommand dat+      go dat "proc-ps"        = procRunCommand dat+      go dat "proc-ssh"       = procRunCommand dat+      -- go dat "proc-telnet"    = procRunCommand dat       go dat "proc-terminate" = procTerminateCommand dat       go dat "proc-message"   = procMessageCommand dat-      go dat _ = cmdRunCommand dat+      go dat "socket-open"    = socketOpenCommand dat+      go dat "socket-close"   = socketCloseCommand dat+      go dat "socket-read"    = socketReadCommand dat+      go dat "socket-write"   = socketWriteCommand dat+      go dat "socket-message" = socketMessageCommand dat+      go dat "socket-telnet"  = socketTelnetCommand dat+      go dat x = do+        $logDebugS DM._LOGTAG $ T.pack $ "handled cmdrun. " ++ show x ++ ": " ++ show dat+        cmdRunCommand dat   -- |@@ -162,3 +176,85 @@    cmdQ <- view DM.cmdRunQueueDomainData <$> lift ask   liftIO $ STM.atomically $ STM.writeTQueue cmdQ $ DM.DefaultCmdRunCommand cmdDat+++-- |+--+socketOpenCommand :: DM.McpToolsCallRequestData -> AppContext ()+socketOpenCommand dat = do+  let cmdDat = DM.SocketOpenCommandData {+                DM._jsonrpcSocketOpenCommandData   = dat^.DM.jsonrpcMcpToolsCallRequestData+              , DM._nameSocketOpenCommandData      = dat^.DM.paramsMcpToolsCallRequestData^.DM.nameMcpToolsCallRequestDataParams+              , DM._argumentsSocketOpenCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.argumentsMcpToolsCallRequestDataParams+              }++  $logDebugS DM._LOGTAG $ T.pack $ "socketOpenCommand" ++ show cmdDat++  cmdQ <- view DM.socketQueueDomainData <$> lift ask+  liftIO $ STM.atomically $ STM.writeTQueue cmdQ $ DM.SocketOpenCommand cmdDat+++-- |+--+socketCloseCommand :: DM.McpToolsCallRequestData -> AppContext ()+socketCloseCommand dat = do+  let cmdDat = DM.SocketCloseCommandData {+                DM._jsonrpcSocketCloseCommandData   = dat^.DM.jsonrpcMcpToolsCallRequestData+              }++  cmdQ <- view DM.socketQueueDomainData <$> lift ask+  liftIO $ STM.atomically $ STM.writeTQueue cmdQ $ DM.SocketCloseCommand cmdDat+++-- |+--+socketReadCommand :: DM.McpToolsCallRequestData -> AppContext ()+socketReadCommand dat = do+  let cmdDat = DM.SocketReadCommandData {+                DM._jsonrpcSocketReadCommandData   = dat^.DM.jsonrpcMcpToolsCallRequestData+              , DM._argumentsSocketReadCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.argumentsMcpToolsCallRequestDataParams+              }++  cmdQ <- view DM.socketQueueDomainData <$> lift ask+  liftIO $ STM.atomically $ STM.writeTQueue cmdQ $ DM.SocketReadCommand cmdDat+++-- |+--+socketWriteCommand :: DM.McpToolsCallRequestData -> AppContext ()+socketWriteCommand dat = do+  let cmdDat = DM.SocketWriteCommandData {+                DM._jsonrpcSocketWriteCommandData   = dat^.DM.jsonrpcMcpToolsCallRequestData+              , DM._argumentsSocketWriteCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.argumentsMcpToolsCallRequestDataParams+              }++  cmdQ <- view DM.socketQueueDomainData <$> lift ask+  liftIO $ STM.atomically $ STM.writeTQueue cmdQ $ DM.SocketWriteCommand cmdDat+++-- |+--+socketMessageCommand :: DM.McpToolsCallRequestData -> AppContext ()+socketMessageCommand dat = do+  let cmdDat = DM.SocketMessageCommandData {+                DM._jsonrpcSocketMessageCommandData   = dat^.DM.jsonrpcMcpToolsCallRequestData+              , DM._argumentsSocketMessageCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.argumentsMcpToolsCallRequestDataParams+              }++  cmdQ <- view DM.socketQueueDomainData <$> lift ask+  liftIO $ STM.atomically $ STM.writeTQueue cmdQ $ DM.SocketMessageCommand cmdDat+++-- |+--+socketTelnetCommand :: DM.McpToolsCallRequestData -> AppContext ()+socketTelnetCommand dat = do+  let cmdDat = DM.SocketTelnetCommandData {+                DM._jsonrpcSocketTelnetCommandData   = dat^.DM.jsonrpcMcpToolsCallRequestData+              , DM._nameSocketTelnetCommandData      = dat^.DM.paramsMcpToolsCallRequestData^.DM.nameMcpToolsCallRequestDataParams+              , DM._argumentsSocketTelnetCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.argumentsMcpToolsCallRequestDataParams+              }++  cmdQ <- view DM.socketQueueDomainData <$> lift ask+  liftIO $ STM.atomically $ STM.writeTQueue cmdQ $ DM.SocketTelnetCommand cmdDat+

@@ -87,6 +87,26 @@  -- | --+instance IStateActivity StartStateData PromptsGetEventData+  -- @see default implementation in Type module.++-- |+--+instance IStateActivity StartStateData ResourcesTemplatesListEventData+  -- @see default implementation in Type module.++-- |+--+instance IStateActivity StartStateData ResourcesListEventData+  -- @see default implementation in Type module.++-- |+--+instance IStateActivity StartStateData ResourcesReadEventData+  -- @see default implementation in Type module.++-- |+-- instance IStateActivity StartStateData CancelledEventData where   action _ dat = do     $logInfoS DM._LOGTAG $ T.pack $ "notifications/cancelled called. " ++ show dat@@ -102,7 +122,3 @@      return noStateTransition --- |----instance IStateActivity StartStateData PromptsGetEventData-  -- @see default implementation in Type module.

@@ -26,13 +26,17 @@      wq <- view DM.watchQueueDomainData <$> lift ask -    $logDebugS DM._LOGTAG "start watch tools-list.json."+    $logDebugS DM._LOGTAG "start watch tools."     let toolCmd = DM.ToolsListWatchCommand DM.ToolsListWatchCommandData     liftIO $ STM.atomically $ STM.writeTQueue wq toolCmd     -    $logDebugS DM._LOGTAG "start watch prompts-list.json."+    $logDebugS DM._LOGTAG "start watch prompts."     let promptsCmd = DM.PromptsListWatchCommand DM.PromptsListWatchCommandData     liftIO $ STM.atomically $ STM.writeTQueue wq promptsCmd++    $logDebugS DM._LOGTAG "start watch resources."+    let resourcesCmd = DM.ResourcesListWatchCommand DM.ResourcesListWatchCommandData+    liftIO $ STM.atomically $ STM.writeTQueue wq resourcesCmd      return $ Just StartToRun 

@@ -84,6 +84,26 @@  -- | --+instance IStateActivity StopStateData PromptsGetEventData+  -- @see default implementation in Type module.++-- |+--+instance IStateActivity StopStateData ResourcesTemplatesListEventData+  -- @see default implementation in Type module.++-- |+--+instance IStateActivity StopStateData ResourcesListEventData+  -- @see default implementation in Type module.++-- |+--+instance IStateActivity StopStateData ResourcesReadEventData+  -- @see default implementation in Type module.++-- |+-- instance IStateActivity StopStateData CancelledEventData where   action _ dat = do     $logInfoS DM._LOGTAG $ T.pack $ "notifications/cancelled called. " ++ show dat@@ -100,8 +120,4 @@      return noStateTransition --- |----instance IStateActivity StopStateData PromptsGetEventData-  -- @see default implementation in Type module.