diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for pms-domain-service +## 0.0.2.0 -- 2025-06-22 + +* Added file change monitoring for tools-list.json. + ## 0.0.1.0 -- 2025-05-31 * First version. diff --git a/pms-domain-service.cabal b/pms-domain-service.cabal --- a/pms-domain-service.cabal +++ b/pms-domain-service.cabal @@ -20,7 +20,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.0.1.0 +version: 0.0.2.0 -- A short (one-line) description of the package. synopsis: pms-domain-service @@ -56,7 +56,7 @@ library -- Import common warning flags. - ghc-options: -Wall -Wno-orphans -Wno-x-partial -Wno-gadt-mono-local-binds + ghc-options: -Wall -threaded -Wno-orphans -Wno-x-partial -Wno-gadt-mono-local-binds -- Modules exported by the library. exposed-modules: PMS.Domain.Service.DM.Type, @@ -66,9 +66,12 @@ PMS.Domain.Service.DM.TH, PMS.Domain.Service.DS.Utility, 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.Start, PMS.Domain.Service.DS.State.Start.Disconnect, - PMS.Domain.Service.DS.State.Start.Init, + 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 @@ -107,7 +110,7 @@ test-suite pms-domain-service-test -- Import common warning flags. - ghc-options: -Wall -Wno-orphans -Wno-x-partial + ghc-options: -Wall -threaded -Wno-orphans -Wno-x-partial -- Base language which the package is written in. default-language: GHC2021 diff --git a/src/PMS/Domain/Service/DM/Constant.hs b/src/PMS/Domain/Service/DM/Constant.hs --- a/src/PMS/Domain/Service/DM/Constant.hs +++ b/src/PMS/Domain/Service/DM/Constant.hs @@ -6,8 +6,3 @@ _LOG_FILE_NAME :: String _LOG_FILE_NAME = "pms-domain-service.log" --- | --- -_TOOLS_LIST_FILE :: String -_TOOLS_LIST_FILE = "tools-list.json" - diff --git a/src/PMS/Domain/Service/DM/TH.hs b/src/PMS/Domain/Service/DM/TH.hs --- a/src/PMS/Domain/Service/DM/TH.hs +++ b/src/PMS/Domain/Service/DM/TH.hs @@ -38,7 +38,7 @@ [InstanceD Nothing [] (AppT (ConT Type.IAppState) (ConT Type.StartState)) [FunD Type.doActivity - [Clause [VarP s_8,ConP Type.EventW [AsP r_9 (RecP Type.InitEvent [])]] (NormalB (AppE (AppE (VarE Type.action) (VarE s_8)) (VarE r_9))) [], + [Clause [VarP s_8,ConP Type.EventW [AsP r_9 (RecP Type.InitializeEvent [])]] (NormalB (AppE (AppE (VarE Type.action) (VarE s_8)) (VarE r_9))) [], Clause [VarP s_10,ConP Type.EventW [AsP r_11 (RecP Type.TerminateEvent [])]] (NormalB (AppE (AppE (VarE Type.action) (VarE s_10)) (VarE r_11))) [] ] ] @@ -55,11 +55,11 @@ :{ runQ [d| data Event r where - InitEvent :: Event InitEvent + InitializeEvent :: Event InitializeEvent |] :} -[DataD [] Event_12 [PlainTV r_14] Nothing [GadtC [InitEvent_13] [] (AppT (ConT Event_12) (ConT Type.InitEvent))] []] +[DataD [] Event_12 [PlainTV r_14] Nothing [GadtC [InitializeEvent_13] [] (AppT (ConT Event_12) (ConT Type.InitializeEvent))] []] -} diff --git a/src/PMS/Domain/Service/DM/Type.hs b/src/PMS/Domain/Service/DM/Type.hs --- a/src/PMS/Domain/Service/DM/Type.hs +++ b/src/PMS/Domain/Service/DM/Type.hs @@ -29,7 +29,7 @@ data ExitEventData = ExitEventData deriving (Show) data TransitEventData = TransitEventData StateTransition deriving (Show) -- doActibity -data InitEventData = InitEventData 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) @@ -44,7 +44,7 @@ ExitEvent :: Event ExitEventData TransitEvent :: TransitEventData -> Event TransitEventData -- doActibity - InitEvent :: InitEventData -> Event InitEventData + InitializeEvent :: InitializeEventData -> Event InitializeEventData InitializedEvent :: InitializedEventData -> Event InitializedEventData ToolsListEvent :: ToolsListEventData -> Event ToolsListEventData ToolsCallEvent :: ToolsCallEventData -> Event ToolsCallEventData diff --git a/src/PMS/Domain/Service/DS/Core.hs b/src/PMS/Domain/Service/DS/Core.hs --- a/src/PMS/Domain/Service/DS/Core.hs +++ b/src/PMS/Domain/Service/DS/Core.hs @@ -76,7 +76,7 @@ -- | -- req2ev :: DM.McpRequest -> AppContext EventW -req2ev (DM.McpInitializeRequest dat) = pure . EventW . InitEvent . InitEventData $ dat +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 diff --git a/src/PMS/Domain/Service/DS/State/Run.hs b/src/PMS/Domain/Service/DS/State/Run.hs --- a/src/PMS/Domain/Service/DS/State/Run.hs +++ b/src/PMS/Domain/Service/DS/State/Run.hs @@ -5,26 +5,15 @@ module PMS.Domain.Service.DS.State.Run where - -import System.IO -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.Exit -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.DM.Constant -import qualified PMS.Domain.Service.DS.Utility as U +import PMS.Domain.Service.DS.State.Run.ToolsList() +import PMS.Domain.Service.DS.State.Run.ToolsCall() instanceTH_IAppState ''RunStateData @@ -50,7 +39,7 @@ -- | -- -instance IStateActivity RunStateData InitEventData +instance IStateActivity RunStateData InitializeEventData -- @see default implementation in Type module. -- | @@ -76,99 +65,3 @@ -- instance IStateActivity RunStateData InitializedEventData -- @see default implementation in Type module. - --- | --- -instance IStateActivity RunStateData ToolsListEventData where - action s (ToolsListEvent r@(ToolsListEventData dat)) = do - $logDebugS DM._LOGTAG "Run ToolsListEvent called." - $logDebugS DM._LOGTAG (T.pack (show s)) - $logDebugS DM._LOGTAG (T.pack (show r)) - - scriptsDir <- view DM.scriptsDirDomainData <$> lift ask - - let toolFile = scriptsDir _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 - - $logDebugS DM._LOGTAG $ T.pack $ show res - - queue <- view DM.responseQueueDomainData <$> lift ask - liftIO $ STM.atomically $ STM.writeTQueue queue res - - return noStateTransition - --- | --- -instance IStateActivity RunStateData ToolsCallEventData where - action _ (ToolsCallEvent (ToolsCallEventData evDat)) = do - $logDebugS DM._LOGTAG "Run ToolsCallEvent called." - - cmd <- genCommand evDat $ evDat^.DM.paramsMcpToolsCallRequestData^.DM.nameMcpToolsCallRequestDataParams - - cmdQ <- view DM.commandQueueDomainData <$> lift ask - liftIO $ STM.atomically $ STM.writeTQueue cmdQ cmd - - return noStateTransition - - where - genCommand :: DM.McpToolsCallRequestData -> String -> AppContext DM.Command - genCommand dat "pty-connect" = genPtyConnectCommand dat - genCommand dat "pty-bash" = genPtyConnectCommand dat - genCommand dat "pty-ssh" = genPtyConnectCommand dat - genCommand dat "pty-cabal" = genPtyConnectCommand dat - genCommand dat "pty-stack" = genPtyConnectCommand dat - genCommand dat "pty-ghci" = genPtyConnectCommand dat - genCommand dat "pty-message" = 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._callbackPtyMessageCommandData = callback resQ - } - - return $ DM.PtyMessageCommand cmdDat - genCommand dat _ = do - resQ <- view DM.responseQueueDomainData <$> lift ask - let cmdDat = DM.SystemCommandData { - DM._nameSystemCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.nameMcpToolsCallRequestDataParams - , DM._argumentsSystemCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.argumentsMcpToolsCallRequestDataParams - , DM._callbackSystemCommandData = callback resQ - } - - return $ DM.SystemCommand cmdDat - - genPtyConnectCommand :: DM.McpToolsCallRequestData -> AppContext DM.Command - genPtyConnectCommand dat = do - resQ <- view DM.responseQueueDomainData <$> lift ask - let cmdDat = DM.PtyConnectCommandData { - DM._namePtyConnectCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.nameMcpToolsCallRequestDataParams - , DM._argumentsPtyConnectCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.argumentsMcpToolsCallRequestDataParams - , DM._callbackPtyConnectCommandData = callback resQ - } - - return $ DM.PtyConnectCommand cmdDat - - -- | - -- - callback :: STM.TQueue DM.McpResponse -> DM.SystemCommandCallback () - callback resQ code outStr errStr = do - hPutStrLn stderr $ "[INFO] PMS.Domain.Service.DS.State.Run.callback called." - - let jsonRpc = evDat^.DM.jsonrpcMcpToolsCallRequestData - content = [ DM.McpToolsCallResponseResultContent "text" outStr - , DM.McpToolsCallResponseResultContent "text" errStr - ] - result = DM.McpToolsCallResponseResult { - DM._contentMcpToolsCallResponseResult = content - , DM._isErrorMcpToolsCallResponseResult = (ExitSuccess /= code) - } - resDat = DM.McpToolsCallResponseData jsonRpc result - res = DM.McpToolsCallResponse resDat - - STM.atomically $ STM.writeTQueue resQ res - - hPutStrLn stderr $ "[INFO] PMS.Domain.Service.DS.State.Run.callback end." diff --git a/src/PMS/Domain/Service/DS/State/Run/ToolsCall.hs b/src/PMS/Domain/Service/DS/State/Run/ToolsCall.hs new file mode 100644 --- /dev/null +++ b/src/PMS/Domain/Service/DS/State/Run/ToolsCall.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} + +module PMS.Domain.Service.DS.State.Run.ToolsCall where + + +import System.IO +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 System.Exit + +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 ToolsCallEventData where + action _ (ToolsCallEvent (ToolsCallEventData evDat)) = do + $logDebugS DM._LOGTAG "Run ToolsCallEvent called." + + go evDat $ evDat^.DM.paramsMcpToolsCallRequestData^.DM.nameMcpToolsCallRequestDataParams + + return noStateTransition + + 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 _ = cmdRunCommand dat + + +-- | +-- +ptyConnectCommand :: DM.McpToolsCallRequestData -> AppContext () +ptyConnectCommand dat = do + resQ <- view DM.responseQueueDomainData <$> lift ask + let cmdDat = DM.PtyConnectCommandData { + DM._namePtyConnectCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.nameMcpToolsCallRequestDataParams + , DM._argumentsPtyConnectCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.argumentsMcpToolsCallRequestDataParams + , DM._callbackPtyConnectCommandData = callback dat resQ + } + + cmdQ <- view DM.commandQueueDomainData <$> lift ask + liftIO $ STM.atomically $ STM.writeTQueue cmdQ $ DM.PtyConnectCommand cmdDat + + +-- | +-- +ptyTerminateCommand :: DM.McpToolsCallRequestData -> AppContext () +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 + } + + cmdQ <- view DM.commandQueueDomainData <$> lift ask + liftIO $ STM.atomically $ STM.writeTQueue cmdQ $ DM.PtyTerminateCommand cmdDat + + +-- | +-- +ptyMessageCommand :: DM.McpToolsCallRequestData -> AppContext () +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._callbackPtyMessageCommandData = callback dat resQ + } + + cmdQ <- view DM.commandQueueDomainData <$> lift ask + liftIO $ STM.atomically $ STM.writeTQueue cmdQ $ DM.PtyMessageCommand cmdDat + + +-- | +-- +callback :: DM.McpToolsCallRequestData -> STM.TQueue DM.McpResponse -> DM.SystemCommandCallback () +callback evDat resQ code outStr errStr = do + hPutStrLn stderr $ "[INFO] PMS.Domain.Service.DS.State.Run.callback called." + + let jsonRpc = evDat^.DM.jsonrpcMcpToolsCallRequestData + content = [ DM.McpToolsCallResponseResultContent "text" outStr + , DM.McpToolsCallResponseResultContent "text" errStr + ] + result = DM.McpToolsCallResponseResult { + DM._contentMcpToolsCallResponseResult = content + , DM._isErrorMcpToolsCallResponseResult = (ExitSuccess /= code) + } + resDat = DM.McpToolsCallResponseData jsonRpc result + res = DM.McpToolsCallResponse resDat + + STM.atomically $ STM.writeTQueue resQ res + + hPutStrLn stderr $ "[INFO] PMS.Domain.Service.DS.State.Run.callback end." + + +-- | +-- +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 + } + + cmdQ2 <- view DM.commandQueueDomainData <$> lift ask + -} + -- liftIO $ STM.atomically $ STM.writeTQueue cmdQ2 $ DM.SystemCommand cmdDat2 + + let cmdDat = DM.DefaultCmdRunCommandData { + DM._jsonrpcDefaultCmdRunCommandData = dat^.DM.jsonrpcMcpToolsCallRequestData + , DM._nameDefaultCmdRunCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.nameMcpToolsCallRequestDataParams + , DM._argumentsDefaultCmdRunCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.argumentsMcpToolsCallRequestDataParams + } + + cmdQ <- view DM.cmdRunQueueDomainData <$> lift ask + liftIO $ STM.atomically $ STM.writeTQueue cmdQ $ DM.DefaultCmdRunCommand cmdDat diff --git a/src/PMS/Domain/Service/DS/State/Run/ToolsList.hs b/src/PMS/Domain/Service/DS/State/Run/ToolsList.hs new file mode 100644 --- /dev/null +++ b/src/PMS/Domain/Service/DS/State/Run/ToolsList.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} + +module PMS.Domain.Service.DS.State.Run.ToolsList 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 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 ToolsListEventData where + action s (ToolsListEvent r@(ToolsListEventData dat)) = 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 + + $logDebugS DM._LOGTAG $ T.pack $ show res + + queue <- view DM.responseQueueDomainData <$> lift ask + liftIO $ STM.atomically $ STM.writeTQueue queue res + + return noStateTransition diff --git a/src/PMS/Domain/Service/DS/State/Start.hs b/src/PMS/Domain/Service/DS/State/Start.hs --- a/src/PMS/Domain/Service/DS/State/Start.hs +++ b/src/PMS/Domain/Service/DS/State/Start.hs @@ -11,7 +11,8 @@ import PMS.Domain.Service.DM.Type import PMS.Domain.Service.DM.TH -import PMS.Domain.Service.DS.State.Start.Init() +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() @@ -23,7 +24,7 @@ actionS s (EventW r@EntryEvent{}) = action s r actionS s (EventW r@ExitEvent{}) = action s r actionS s (EventW r@TransitEvent{}) = action s r - actionS s (EventW r@InitEvent{}) = action s r + actionS s (EventW r@InitializeEvent{}) = action s r actionS s (EventW r@LaunchEvent{}) = action s r actionS s (EventW r@DisconnectEvent{}) = action s r actionS s (EventW r@TerminateEvent{}) = action s r @@ -52,10 +53,21 @@ -- | -- +{- instance IStateActivity StartStateData InitializedEventData where action _ _ = do $logDebugS DM._LOGTAG "initialized called." + + $logDebugS DM._LOGTAG "start watch tools-list.json." + let jsonRpc = dat^.DM.jsonrpcMcpToolsListRequestData + cmdDat = DM.ToolsListWatchCommandData jsonRpc + cmd = DM.ToolsListWatchCommand cmdDat + + wq <- view DM.watchQueueDomainData <$> lift ask + liftIO $ STM.atomically $ STM.writeTQueue wq cmd + return $ Just StartToRun +-} -- | -- diff --git a/src/PMS/Domain/Service/DS/State/Start/Init.hs b/src/PMS/Domain/Service/DS/State/Start/Init.hs deleted file mode 100644 --- a/src/PMS/Domain/Service/DS/State/Start/Init.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} - -module PMS.Domain.Service.DS.State.Start.Init where - -import Data.Default -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Logger -import Control.Monad.Reader -import Control.Lens -import qualified Data.Text as T -import qualified Control.Concurrent.STM as STM - -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 StartStateData InitEventData where - action s (InitEvent r@(InitEventData dat)) = do - $logDebugS DM._LOGTAG "Start init called." - $logDebugS DM._LOGTAG (T.pack (show s)) - $logDebugS DM._LOGTAG (T.pack (show r)) - - let jsonRpc = dat^.DM.jsonrpcMcpInitializeRequestData - resDat = DM.McpInitializeResponseData jsonRpc def - res = DM.McpInitializeResponse resDat - - $logDebugS DM._LOGTAG $ T.pack $ show res - - queue <- view DM.responseQueueDomainData <$> lift ask - liftIO $ STM.atomically $ STM.writeTQueue queue res - - return Nothing - diff --git a/src/PMS/Domain/Service/DS/State/Start/Initialize.hs b/src/PMS/Domain/Service/DS/State/Start/Initialize.hs new file mode 100644 --- /dev/null +++ b/src/PMS/Domain/Service/DS/State/Start/Initialize.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module PMS.Domain.Service.DS.State.Start.Initialize where + +import Data.Default +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Logger +import Control.Monad.Reader +import Control.Lens +import qualified Data.Text as T +import qualified Control.Concurrent.STM as STM + +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 StartStateData InitializeEventData where + action s (InitializeEvent r@(InitializeEventData dat)) = do + $logDebugS DM._LOGTAG "Start init called." + $logDebugS DM._LOGTAG (T.pack (show s)) + $logDebugS DM._LOGTAG (T.pack (show r)) + + let jsonRpc = dat^.DM.jsonrpcMcpInitializeRequestData + resDat = DM.McpInitializeResponseData jsonRpc def + res = DM.McpInitializeResponse resDat + + $logDebugS DM._LOGTAG $ T.pack $ show res + + queue <- view DM.responseQueueDomainData <$> lift ask + liftIO $ STM.atomically $ STM.writeTQueue queue res + + return Nothing + diff --git a/src/PMS/Domain/Service/DS/State/Start/Initialized.hs b/src/PMS/Domain/Service/DS/State/Start/Initialized.hs new file mode 100644 --- /dev/null +++ b/src/PMS/Domain/Service/DS/State/Start/Initialized.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module PMS.Domain.Service.DS.State.Start.Initialized where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Logger +import Control.Monad.Reader +import Control.Lens +import qualified Control.Concurrent.STM as STM + +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 StartStateData InitializedEventData where + 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 + + return $ Just StartToRun + diff --git a/src/PMS/Domain/Service/DS/State/Stop.hs b/src/PMS/Domain/Service/DS/State/Stop.hs --- a/src/PMS/Domain/Service/DS/State/Stop.hs +++ b/src/PMS/Domain/Service/DS/State/Stop.hs @@ -37,7 +37,7 @@ -- | -- -instance IStateActivity StopStateData InitEventData +instance IStateActivity StopStateData InitializeEventData -- @see default implementation in Type module. -- |