packages feed

pms-domain-service 0.0.2.0 → 0.0.3.0

raw patch · 16 files changed

+397/−118 lines, 16 filesdep +mustachedep +unordered-containers

Dependencies added: mustache, unordered-containers

Files

CHANGELOG.md view
@@ -1,5 +1,9 @@ # Revision history for pms-domain-service +## 0.0.3.0 -- 2025-06-29++* Added prompts interface.+ ## 0.0.2.0 -- 2025-06-22  * Added file change monitoring for tools-list.json.
pms-domain-service.cabal view
@@ -20,7 +20,7 @@ -- PVP summary:     +-+------- breaking API changes --                  | | +----- non-breaking API additions --                  | | | +--- code changes with no API change-version:            0.0.2.0+version:            0.0.3.0  -- A short (one-line) description of the package. synopsis:           pms-domain-service@@ -68,12 +68,11 @@                       PMS.Domain.Service.DS.State.Run,                       PMS.Domain.Service.DS.State.Run.ToolsList,                       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.Start,-                      PMS.Domain.Service.DS.State.Start.Disconnect,                       PMS.Domain.Service.DS.State.Start.Initialize,                       PMS.Domain.Service.DS.State.Start.Initialized,-                      PMS.Domain.Service.DS.State.Start.Launch,-                      PMS.Domain.Service.DS.State.Start.Terminate,                       PMS.Domain.Service.DS.State.Stop      -- Modules included in this library but not exported.@@ -99,6 +98,8 @@                       filepath,                       directory,                       aeson,+                      unordered-containers,+                      mustache,                       pms-domain-model      -- Directories containing source files.
src/PMS/Domain/Service/DM/Type.hs view
@@ -11,10 +11,27 @@ import qualified PMS.Domain.Model.DM.Type as DM import qualified PMS.Domain.Model.DM.Constant as DM +import Data.Aeson+import qualified Data.Aeson.KeyMap as KM+import Data.Aeson.Key (toText)+import Control.Monad (forM)  -------------------------------------------------------------------------------- -- | --+newtype JsonObjectMap = JsonObjectMap { unJsonObjectMap :: [(String, String)] }+  deriving (Show)++instance FromJSON JsonObjectMap where+  parseJSON = withObject "JsonObjectMap" $ \o -> do+    listPairs <- forM (KM.toList o) $ \(k, v) -> do+      stringValue <- parseJSON v+      return (T.unpack (toText k), T.unpack stringValue)+    return $ JsonObjectMap listPairs++--------------------------------------------------------------------------------+-- |+-- data StateTransition =     StartToRun   | RunToStop@@ -29,14 +46,16 @@ data ExitEventData        = ExitEventData  deriving (Show) data TransitEventData     = TransitEventData StateTransition deriving (Show) -- doActibity-data InitializeEventData        = InitializeEventData DM.McpInitializeRequestData deriving (Show)+data InitializeEventData  = InitializeEventData DM.McpInitializeRequestData deriving (Show) data InitializedEventData = InitializedEventData DM.McpInitializedNotificationData deriving (Show) data ToolsListEventData   = ToolsListEventData DM.McpToolsListRequestData deriving (Show) data ToolsCallEventData   = ToolsCallEventData DM.McpToolsCallRequestData deriving (Show)-data LaunchEventData      = LaunchEventData Int deriving (Show)-data DisconnectEventData  = DisconnectEventData Int deriving (Show)-data TerminateEventData   = TerminateEventData Int  deriving (Show)+data PromptsListEventData = PromptsListEventData DM.McpPromptsListRequestData deriving (Show)+data CancelledEventData   = CancelledEventData DM.McpCancelledNotificationData deriving (Show)+data CompletionCompleteEventData = CompletionCompleteEventData DM.McpCompletionCompleteRequestData deriving (Show)+data PromptsGetEventData         = PromptsGetEventData DM.McpPromptsGetRequestData deriving (Show) + -- | -- data Event r where@@ -48,9 +67,10 @@   InitializedEvent :: InitializedEventData -> Event InitializedEventData   ToolsListEvent   :: ToolsListEventData   -> Event ToolsListEventData   ToolsCallEvent   :: ToolsCallEventData   -> Event ToolsCallEventData-  LaunchEvent      :: LaunchEventData      -> Event LaunchEventData-  DisconnectEvent  :: DisconnectEventData  -> Event DisconnectEventData-  TerminateEvent   :: TerminateEventData   -> Event TerminateEventData+  PromptsListEvent :: PromptsListEventData -> Event PromptsListEventData+  CancelledEvent   :: CancelledEventData   -> Event CancelledEventData+  CompletionCompleteEvent :: CompletionCompleteEventData -> Event CompletionCompleteEventData+  PromptsGetEvent         :: PromptsGetEventData -> Event PromptsGetEventData  deriving instance Show r => Show (Event r)
src/PMS/Domain/Service/DS/Core.hs view
@@ -77,9 +77,13 @@ -- req2ev :: DM.McpRequest -> AppContext EventW req2ev (DM.McpInitializeRequest dat) = pure . EventW . InitializeEvent . InitializeEventData $ dat-req2ev (DM.McpInitializedNotification dat) = pure . EventW . InitializedEvent . InitializedEventData $ dat 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.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  --------------------------------------------------------------------------------- -- |
src/PMS/Domain/Service/DS/State/Run.hs view
@@ -6,14 +6,19 @@ module PMS.Domain.Service.DS.State.Run where  import Control.Monad.Logger+import qualified Data.Text as T+import Control.Lens +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 PMS.Domain.Service.DM.TH-+import PMS.Domain.Service.DS.Utility import PMS.Domain.Service.DS.State.Run.ToolsList() import PMS.Domain.Service.DS.State.Run.ToolsCall()+import PMS.Domain.Service.DS.State.Run.PromptsList()+import PMS.Domain.Service.DS.State.Run.PromptsGet()   instanceTH_IAppState ''RunStateData@@ -23,14 +28,14 @@ instance IStateActivity RunStateData EntryEventData where   action _ _ = do     $logDebugS DM._LOGTAG "Run entry called."-    return Nothing+    return noStateTransition  -- | -- instance IStateActivity RunStateData ExitEventData where   action _ _ = do     $logDebugS DM._LOGTAG "Run exit called."-    return Nothing+    return noStateTransition  -- | --@@ -44,24 +49,25 @@  -- | ---instance IStateActivity RunStateData LaunchEventData where-  action _ _ = do-    $logDebugS DM._LOGTAG "Run launch called."-    return Nothing+instance IStateActivity RunStateData InitializedEventData+  -- @see default implementation in Type module. --- |----instance IStateActivity RunStateData DisconnectEventData where-  action _ _ = do-    $logDebugS DM._LOGTAG "Run discoonect called."-    return $ Just RunToStop  -- | ---instance IStateActivity RunStateData TerminateEventData-  -- @see default implementation in Type module.+instance IStateActivity RunStateData CancelledEventData where+  action _ dat = do+    $logInfoS DM._LOGTAG $ T.pack $ "notifications/cancelled called. " ++ show dat+    return noStateTransition + -- | ---instance IStateActivity RunStateData InitializedEventData-  -- @see default implementation in Type module.+instance IStateActivity RunStateData CompletionCompleteEventData where+  action _ (CompletionCompleteEvent (CompletionCompleteEventData evDat)) = do+    $logInfoS DM._LOGTAG $ T.pack $ "CompletionCompleteEvent called. " ++ show evDat++    sendCompletionResponse $ evDat^.DM.jsonrpcMcpCompletionCompleteRequestData++    return noStateTransition+
+ src/PMS/Domain/Service/DS/State/Run/PromptsGet.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++module PMS.Domain.Service.DS.State.Run.PromptsGet 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 System.FilePath+import Data.Default+import Text.Mustache+import qualified Data.Aeson as Aeson+import Data.Bifunctor++import qualified PMS.Domain.Model.DM.Type as DM+import qualified PMS.Domain.Model.DM.Constant as DM++import PMS.Domain.Service.DM.Type+++-- |+--+instance IStateActivity RunStateData PromptsGetEventData where+  action _ (PromptsGetEvent (PromptsGetEventData evDat)) = flip catchError errHdl $ do+    $logDebugS DM._LOGTAG $ T.pack $ "Run PromptsGetEvent called." ++ show evDat++    let params = evDat^.DM.paramsMcpPromptsGetRequestData+        name = params^.DM.nameMcpPromptsGetRequestDataParams+        argsBS = DM.unRawJsonByteString $ params^.DM.argumentsMcpPromptsGetRequestDataParams+    +    promptsDir <- view DM.promptsDirDomainData <$> lift ask+    let promptsFile = name ++ ".md"+        promptsFilePath = promptsDir </> promptsFile+    +    argsDat <- liftEither $ eitherDecode $ argsBS+    let args = unJsonObjectMap argsDat+        +    $logDebugS DM._LOGTAG $ T.pack $ "promptsFile : " ++ promptsFile+    $logDebugS DM._LOGTAG $ T.pack $ "promptsFilePath : " ++ promptsFilePath+    $logDebugS DM._LOGTAG $ T.pack $ "arguments : " ++ show args++    tmplParams <- liftEither $ eitherDecode $ argsBS+    tmplTmp <- liftIO $ automaticCompile [promptsDir] promptsFile+    tmpl <- liftEither $ first show tmplTmp+    let rendered = substitute tmpl (tmplParams :: Aeson.Value)+        cont = T.unpack rendered+    +    -- cont <- U.readFile promptsFilePath+    -- response $ TL.unpack $ TLE.decodeUtf8 cont++    response cont+    +    return noStateTransition++    where+      errHdl :: String -> AppContext (Maybe StateTransition)+      errHdl msg = do+        $logErrorS DM._LOGTAG $ T.pack $ "PromptsGetEventData: exception occurred. " ++ msg+        response msg+        return noStateTransition++      response :: String -> AppContext ()+      response cont = do+        let role = "assistant"+            txtDat = def {DM._textMcpTextContent = cont} +            content = encode txtDat+            msg = DM.McpPromptsGetResponseResultPromptMessage role (DM.RawJsonByteString content)+            result = DM.McpPromptsGetResponseResult [msg]+            jsonRpc = evDat^.DM.jsonrpcMcpPromptsGetRequestData+            resDat = DM.McpPromptsGetResponseData jsonRpc result+            res = DM.McpPromptsGetResponse resDat++        $logDebugS DM._LOGTAG $ T.pack $ show res++        queue <- view DM.responseQueueDomainData <$> lift ask+        liftIO $ STM.atomically $ STM.writeTQueue queue res+
+ src/PMS/Domain/Service/DS/State/Run/PromptsList.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++module PMS.Domain.Service.DS.State.Run.PromptsList 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 PromptsListEventData where+  action _ (PromptsListEvent (PromptsListEventData dat)) = flip catchError errHdl $ do+    $logDebugS DM._LOGTAG "Run PromptsListEvent called."++    promptsDir <- view DM.promptsDirDomainData <$> lift ask++    let promptsFile = promptsDir </> DM._PROMPTS_LIST_FILE+    exists <- liftIO $ doesFileExist promptsFile+    cont <- if exists+              then U.readFile promptsFile+              else do+                $logInfoS DM._LOGTAG $ T.pack $ "file not found." ++ promptsFile+                return "[]"++    response cont+    return noStateTransition++    where+      errHdl :: String -> AppContext (Maybe StateTransition)+      errHdl msg = do+        $logErrorS DM._LOGTAG $ T.pack $ "PromptsListEventData: exception occurred. " ++ msg+        response $ BL8.pack msg+        return noStateTransition++      response :: BL.ByteString -> AppContext ()+      response cont = do+        let result = DM.McpPromptsListResponseResult $ DM.RawJsonByteString cont+            jsonRpc = dat^.DM.jsonrpcMcpPromptsListRequestData+            resDat = DM.McpPromptsListResponseData jsonRpc result+            res = DM.McpPromptsListResponse resDat++        $logDebugS DM._LOGTAG $ T.pack $ show res++        queue <- view DM.responseQueueDomainData <$> lift ask+        liftIO $ STM.atomically $ STM.writeTQueue queue res
src/PMS/Domain/Service/DS/State/Run/ToolsCall.hs view
@@ -33,14 +33,17 @@          where       go :: DM.McpToolsCallRequestData -> String -> AppContext ()-      go dat "pty-connect"   = ptyConnectCommand dat-      go dat "pty-terminate" = ptyTerminateCommand dat-      go dat "pty-message"   = ptyMessageCommand dat-      go dat "pty-bash"      = ptyConnectCommand dat-      go dat "pty-ssh"       = ptyConnectCommand dat-      go dat "pty-cabal"     = ptyConnectCommand dat-      go dat "pty-stack"     = ptyConnectCommand dat-      go dat "pty-ghci"      = ptyConnectCommand dat+      go dat "pty-connect"    = ptyConnectCommand dat+      go dat "pty-terminate"  = ptyTerminateCommand dat+      go dat "pty-message"    = ptyMessageCommand dat+      go dat "pty-bash"       = ptyConnectCommand dat+      go dat "pty-ssh"        = 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-terminate" = procTerminateCommand dat+      go dat "proc-message"   = procMessageCommand dat       go dat _ = cmdRunCommand dat  @@ -65,9 +68,7 @@ ptyTerminateCommand dat = do   resQ <- view DM.responseQueueDomainData <$> lift ask   let cmdDat = DM.PtyTerminateCommandData {-                DM._namePtyTerminateCommandData      = dat^.DM.paramsMcpToolsCallRequestData^.DM.nameMcpToolsCallRequestDataParams-              , DM._argumentsPtyTerminateCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.argumentsMcpToolsCallRequestDataParams-              , DM._callbackPtyTerminateCommandData  = callback dat resQ+                DM._callbackPtyTerminateCommandData  = callback dat resQ               }    cmdQ <- view DM.commandQueueDomainData <$> lift ask@@ -80,8 +81,7 @@ ptyMessageCommand dat = do   resQ <- view DM.responseQueueDomainData <$> lift ask   let cmdDat = DM.PtyMessageCommandData {-                DM._namePtyMessageCommandData      = dat^.DM.paramsMcpToolsCallRequestData^.DM.nameMcpToolsCallRequestDataParams-              , DM._argumentsPtyMessageCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.argumentsMcpToolsCallRequestDataParams+                DM._argumentsPtyMessageCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.argumentsMcpToolsCallRequestDataParams               , DM._callbackPtyMessageCommandData  = callback dat resQ               } @@ -91,7 +91,7 @@  -- | ---callback :: DM.McpToolsCallRequestData -> STM.TQueue DM.McpResponse -> DM.SystemCommandCallback ()+callback :: DM.McpToolsCallRequestData -> STM.TQueue DM.McpResponse -> DM.ToolsCallCommandCallback () callback evDat resQ code outStr errStr = do   hPutStrLn stderr $ "[INFO] PMS.Domain.Service.DS.State.Run.callback called." @@ -113,20 +113,47 @@  -- | ---cmdRunCommand :: DM.McpToolsCallRequestData -> AppContext ()-cmdRunCommand dat = do-  {--  resQ <- view DM.responseQueueDomainData <$> lift ask-  let cmdDat2 = DM.SystemCommandData {-                DM._nameSystemCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.nameMcpToolsCallRequestDataParams-              , DM._argumentsSystemCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.argumentsMcpToolsCallRequestDataParams-              , DM._callbackSystemCommandData = callback dat resQ+procRunCommand :: DM.McpToolsCallRequestData -> AppContext ()+procRunCommand dat = do+  let cmdDat = DM.ProcRunCommandData {+                DM._jsonrpcProcRunCommandData   = dat^.DM.jsonrpcMcpToolsCallRequestData+              , DM._nameProcRunCommandData      = dat^.DM.paramsMcpToolsCallRequestData^.DM.nameMcpToolsCallRequestDataParams+              , DM._argumentsProcRunCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.argumentsMcpToolsCallRequestDataParams               } -  cmdQ2 <- view DM.commandQueueDomainData <$> lift ask-  -}-  -- liftIO $ STM.atomically $ STM.writeTQueue cmdQ2 $ DM.SystemCommand cmdDat2+  cmdQ <- view DM.procspawnQueueDomainData <$> lift ask+  liftIO $ STM.atomically $ STM.writeTQueue cmdQ $ DM.ProcRunCommand cmdDat ++-- |+--+procTerminateCommand :: DM.McpToolsCallRequestData -> AppContext ()+procTerminateCommand dat = do+  let cmdDat = DM.ProcTerminateCommandData {+                DM._jsonrpcProcTerminateCommandData   = dat^.DM.jsonrpcMcpToolsCallRequestData+              }++  cmdQ <- view DM.procspawnQueueDomainData <$> lift ask+  liftIO $ STM.atomically $ STM.writeTQueue cmdQ $ DM.ProcTerminateCommand cmdDat+++-- |+--+procMessageCommand :: DM.McpToolsCallRequestData -> AppContext ()+procMessageCommand dat = do+  let cmdDat = DM.ProcMessageCommandData {+                DM._jsonrpcProcMessageCommandData   = dat^.DM.jsonrpcMcpToolsCallRequestData+              , DM._argumentsProcMessageCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.argumentsMcpToolsCallRequestDataParams+              }++  cmdQ <- view DM.procspawnQueueDomainData <$> lift ask+  liftIO $ STM.atomically $ STM.writeTQueue cmdQ $ DM.ProcMessageCommand cmdDat+++-- |+--+cmdRunCommand :: DM.McpToolsCallRequestData -> AppContext ()+cmdRunCommand dat = do   let cmdDat = DM.DefaultCmdRunCommandData {                 DM._jsonrpcDefaultCmdRunCommandData   = dat^.DM.jsonrpcMcpToolsCallRequestData               , DM._nameDefaultCmdRunCommandData      = dat^.DM.paramsMcpToolsCallRequestData^.DM.nameMcpToolsCallRequestDataParams
src/PMS/Domain/Service/DS/State/Run/ToolsList.hs view
@@ -13,6 +13,10 @@ 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@@ -24,23 +28,37 @@ -- | -- instance IStateActivity RunStateData ToolsListEventData where-  action s (ToolsListEvent r@(ToolsListEventData dat)) = do+  action _ (ToolsListEvent (ToolsListEventData dat)) = flip catchError errHdl $ do     $logDebugS DM._LOGTAG "Run ToolsListEvent called."-    $logDebugS DM._LOGTAG (T.pack (show s))-    $logDebugS DM._LOGTAG (T.pack (show r))      toolsDir <- view DM.toolsDirDomainData <$> lift ask      let toolFile = toolsDir </> DM._TOOLS_LIST_FILE-    cont <- U.readFile toolFile-    let result = DM.McpToolsListResponseResult $ DM.RawJsonByteString cont-        jsonRpc = dat^.DM.jsonrpcMcpToolsListRequestData-        resDat = DM.McpToolsListResponseData jsonRpc result-        res = DM.McpToolsListResponse resDat+    exists <- liftIO $ doesFileExist toolFile+    cont <- if exists+              then U.readFile toolFile+              else do+                $logInfoS DM._LOGTAG $ T.pack $ "file not found." ++ toolFile+                return "[]" -    $logDebugS DM._LOGTAG $ T.pack $ show res+    response cont+    return noStateTransition -    queue <- view DM.responseQueueDomainData <$> lift ask-    liftIO $ STM.atomically $ STM.writeTQueue queue res+    where+      errHdl :: String -> AppContext (Maybe StateTransition)+      errHdl msg = do+        $logErrorS DM._LOGTAG $ T.pack $ "PromptsListEventData: exception occurred. " ++ msg+        response $ BL8.pack msg+        return noStateTransition -    return noStateTransition+      response :: BL.ByteString -> AppContext ()+      response cont = do+        let result = DM.McpToolsListResponseResult $ DM.RawJsonByteString cont+            jsonRpc = dat^.DM.jsonrpcMcpToolsListRequestData+            resDat = DM.McpToolsListResponseData jsonRpc result+            res = DM.McpToolsListResponse resDat++        $logDebugS DM._LOGTAG $ T.pack $ show res++        queue <- view DM.responseQueueDomainData <$> lift ask+        liftIO $ STM.atomically $ STM.writeTQueue queue res
src/PMS/Domain/Service/DS/State/Start.hs view
@@ -6,16 +6,17 @@ module PMS.Domain.Service.DS.State.Start where  import Control.Monad.Logger+import qualified Data.Text as T+import Control.Lens +import qualified PMS.Domain.Model.DM.Type as DM import qualified PMS.Domain.Model.DM.Constant as DM +import PMS.Domain.Service.DS.Utility import PMS.Domain.Service.DM.Type import PMS.Domain.Service.DM.TH import PMS.Domain.Service.DS.State.Start.Initialize() import PMS.Domain.Service.DS.State.Start.Initialized()-import PMS.Domain.Service.DS.State.Start.Launch()-import PMS.Domain.Service.DS.State.Start.Disconnect()-import PMS.Domain.Service.DS.State.Start.Terminate()  {- -- |@@ -36,14 +37,14 @@ instance IStateActivity StartStateData EntryEventData where   action _ _ = do     $logDebugS DM._LOGTAG "Start entry called."-    return Nothing+    return noStateTransition  -- | -- instance IStateActivity StartStateData ExitEventData where   action _ _ = do     $logDebugS DM._LOGTAG "Start exit called."-    return Nothing+    return noStateTransition  -- | --@@ -77,4 +78,31 @@ -- | -- instance IStateActivity StartStateData ToolsCallEventData+  -- @see default implementation in Type module.++-- |+--+instance IStateActivity StartStateData PromptsListEventData+  -- @see default implementation in Type module.++-- |+--+instance IStateActivity StartStateData CancelledEventData where+  action _ dat = do+    $logInfoS DM._LOGTAG $ T.pack $ "notifications/cancelled called. " ++ show dat+    return noStateTransition++-- |+--+instance IStateActivity StartStateData CompletionCompleteEventData where+  action _ (CompletionCompleteEvent (CompletionCompleteEventData evDat)) = do+    $logInfoS DM._LOGTAG $ T.pack $ "CompletionCompleteEvent called. " ++ show evDat++    sendCompletionResponse $ evDat^.DM.jsonrpcMcpCompletionCompleteRequestData++    return noStateTransition++-- |+--+instance IStateActivity StartStateData PromptsGetEventData   -- @see default implementation in Type module.
− src/PMS/Domain/Service/DS/State/Start/Disconnect.hs 
@@ -1,12 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module PMS.Domain.Service.DS.State.Start.Disconnect where--import PMS.Domain.Service.DM.Type---- |----instance IStateActivity StartStateData DisconnectEventData-  -- @see default implementation in Type module.-
src/PMS/Domain/Service/DS/State/Start/Initialized.hs view
@@ -24,11 +24,15 @@   action _ (InitializedEvent (InitializedEventData _)) = do     $logDebugS DM._LOGTAG "initialized called." -    $logDebugS DM._LOGTAG "start watch tools-list.json."-    let cmd = DM.ToolsListWatchCommand DM.ToolsListWatchCommandData-     wq <- view DM.watchQueueDomainData <$> lift ask-    liftIO $ STM.atomically $ STM.writeTQueue wq cmd++    $logDebugS DM._LOGTAG "start watch tools-list.json."+    let toolCmd = DM.ToolsListWatchCommand DM.ToolsListWatchCommandData+    liftIO $ STM.atomically $ STM.writeTQueue wq toolCmd     +    $logDebugS DM._LOGTAG "start watch prompts-list.json."+    let promptsCmd = DM.PromptsListWatchCommand DM.PromptsListWatchCommandData+    liftIO $ STM.atomically $ STM.writeTQueue wq promptsCmd+     return $ Just StartToRun
− src/PMS/Domain/Service/DS/State/Start/Launch.hs 
@@ -1,13 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module PMS.Domain.Service.DS.State.Start.Launch where--import PMS.Domain.Service.DM.Type----- |----instance IStateActivity StartStateData LaunchEventData-  -- @see default implementation in Type module.-
− src/PMS/Domain/Service/DS/State/Start/Terminate.hs 
@@ -1,13 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module PMS.Domain.Service.DS.State.Start.Terminate where--import PMS.Domain.Service.DM.Type----- |----instance IStateActivity StartStateData TerminateEventData-  -- @see default implementation in Type module.-
src/PMS/Domain/Service/DS/State/Stop.hs view
@@ -6,9 +6,13 @@ module PMS.Domain.Service.DS.State.Stop where  import Control.Monad.Logger+import qualified Data.Text as T+import Control.Lens +import qualified PMS.Domain.Model.DM.Type as DM import qualified PMS.Domain.Model.DM.Constant as DM +import PMS.Domain.Service.DS.Utility import PMS.Domain.Service.DM.Type import PMS.Domain.Service.DM.TH @@ -21,14 +25,14 @@ instance IStateActivity StopStateData EntryEventData where   action _ _ = do     $logDebugS DM._LOGTAG "Stop entry called."-    return Nothing+    return noStateTransition  -- | -- instance IStateActivity StopStateData ExitEventData where   action _ _ = do     $logDebugS DM._LOGTAG "Stop exit called."-    return Nothing+    return noStateTransition  -- | --@@ -42,21 +46,22 @@  -- | ---instance IStateActivity StopStateData LaunchEventData+-- instance IStateActivity StopStateData LaunchEventData   -- @see default implementation in Type module.  -- | ---instance IStateActivity StopStateData DisconnectEventData+-- instance IStateActivity StopStateData DisconnectEventData   -- @see default implementation in Type module.  -- | --+{- instance IStateActivity StopStateData TerminateEventData where   action _ _ = do     $logDebugS DM._LOGTAG "Stop terminate called. will exit."     return Nothing-+-} -- | -- instance IStateActivity StopStateData InitializedEventData@@ -71,3 +76,32 @@ -- instance IStateActivity StopStateData ToolsCallEventData   -- @see default implementation in Type module.++-- |+--+instance IStateActivity StopStateData PromptsListEventData+  -- @see default implementation in Type module.++-- |+--+instance IStateActivity StopStateData CancelledEventData where+  action _ dat = do+    $logInfoS DM._LOGTAG $ T.pack $ "notifications/cancelled called. " ++ show dat+    return noStateTransition+++-- |+--+instance IStateActivity StopStateData CompletionCompleteEventData where+  action _ (CompletionCompleteEvent (CompletionCompleteEventData evDat)) = do+    $logInfoS DM._LOGTAG $ T.pack $ "CompletionCompleteEvent called. " ++ show evDat++    sendCompletionResponse $ evDat^.DM.jsonrpcMcpCompletionCompleteRequestData++    return noStateTransition++-- |+--+instance IStateActivity StopStateData PromptsGetEventData+  -- @see default implementation in Type module.+
src/PMS/Domain/Service/DS/Utility.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}  module PMS.Domain.Service.DS.Utility where @@ -11,9 +12,16 @@ import qualified Data.Text.Encoding as TE import qualified Data.ByteString.Lazy as BL import System.Directory+import Control.Monad.Logger+import qualified Control.Concurrent.STM as STM+import Control.Lens+import Data.Default+import qualified Data.Text as T  import qualified PMS.Domain.Model.DM.Type as DM import qualified PMS.Domain.Model.DS.Utility as DM+import qualified PMS.Domain.Model.DM.Constant as DM+ import PMS.Domain.Service.DM.Type  @@ -74,3 +82,16 @@ isReadable f = liftIOE (readable <$> getPermissions f) >>= \case   True  -> return f   False -> throwError $ "invalid file. not readable." ++ f++-- |+--+sendCompletionResponse :: DM.JsonRpcRequest -> AppContext ()+sendCompletionResponse jsonRpc = do+  let result = def+      resDat = DM.McpCompleteResponseData jsonRpc result+      res = DM.McpCompleteResponse resDat++  $logDebugS DM._LOGTAG $ T.pack $ show res++  queue <- view DM.responseQueueDomainData <$> lift ask+  liftIO $ STM.atomically $ STM.writeTQueue queue res