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.5.0 -- 2025-07-13 + +* Added serial tool. + ## 0.0.4.0 -- 2025-07-06 * Added resources interface. diff --git a/pms-domain-service.cabal b/pms-domain-service.cabal --- a/pms-domain-service.cabal +++ b/pms-domain-service.cabal @@ -1,4 +1,4 @@ -cabal-version: 3.12 +cabal-version: 2.4 -- The cabal-version field refers to the version of the .cabal specification, -- and can be different from the cabal-install (the tool) version and the -- Cabal (the library) version you are using. As such, the Cabal (the library) @@ -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-service @@ -56,7 +56,8 @@ library -- Import common warning flags. - ghc-options: -Wall -threaded -Wno-orphans -Wno-x-partial -Wno-gadt-mono-local-binds +-- ghc-options: -Wall -threaded -Wno-orphans -Wno-x-partial -Wno-gadt-mono-local-binds + ghc-options: -Wall -threaded -Wno-orphans -Wno-gadt-mono-local-binds -- Modules exported by the library. exposed-modules: PMS.Domain.Service.DM.Type, @@ -85,7 +86,7 @@ -- other-extensions: -- Other library packages from which modules are imported. - build-depends: base ^>=4.21.0.0, + build-depends: base >= 4.18 && < 5, transformers, mtl, text, @@ -110,15 +111,16 @@ hs-source-dirs: src -- Base language which the package is written in. - default-language: GHC2021 - default-extensions: LambdaCase + default-language: Haskell2010 + -- default-extensions: LambdaCase test-suite pms-domain-service-test -- Import common warning flags. - ghc-options: -Wall -threaded -Wno-orphans -Wno-x-partial + ghc-options: -Wall -threaded -Wno-orphans +-- ghc-options: -Wall -threaded -Wno-orphans -Wno-x-partial -- Base language which the package is written in. - default-language: GHC2021 + default-language: Haskell2010 -- Modules included in this executable, other than Main. other-modules: PMS.Domain.Service.App.ControlSpec @@ -136,7 +138,7 @@ main-is: Spec.hs -- Test dependencies. - build-depends: base ^>=4.21.0.0, + build-depends: base >= 4.18 && < 5, hspec, hspec-discover, data-default, 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 @@ -1,4 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} module PMS.Domain.Service.DM.Type where diff --git a/src/PMS/Domain/Service/DS/State/Run/PromptsGet.hs b/src/PMS/Domain/Service/DS/State/Run/PromptsGet.hs --- a/src/PMS/Domain/Service/DS/State/Run/PromptsGet.hs +++ b/src/PMS/Domain/Service/DS/State/Run/PromptsGet.hs @@ -34,11 +34,11 @@ $logDebugS DM._LOGTAG $ T.pack $ "Run PromptsGetEvent called." ++ show evDat let params = evDat^.DM.paramsMcpPromptsGetRequestData - name = params^.DM.nameMcpPromptsGetRequestDataParams + pname = params^.DM.nameMcpPromptsGetRequestDataParams argsBS = DM.unRawJsonByteString $ params^.DM.argumentsMcpPromptsGetRequestDataParams promptsDir <- view DM.promptsDirDomainData <$> lift ask - let promptsFile = name ++ ".md" + let promptsFile = pname ++ ".md" promptsFilePath = promptsDir promptsFile argsDat <- liftEither $ eitherDecode $ argsBS diff --git a/src/PMS/Domain/Service/DS/State/Run/ToolsCall.hs b/src/PMS/Domain/Service/DS/State/Run/ToolsCall.hs --- a/src/PMS/Domain/Service/DS/State/Run/ToolsCall.hs +++ b/src/PMS/Domain/Service/DS/State/Run/ToolsCall.hs @@ -56,6 +56,11 @@ go dat "socket-write" = socketWriteCommand dat go dat "socket-message" = socketMessageCommand dat go dat "socket-telnet" = socketTelnetCommand dat + go dat "serial-open" = serialOpenCommand dat + go dat "serial-close" = serialCloseCommand dat + go dat "serial-read" = serialReadCommand dat + go dat "serial-write" = serialWriteCommand dat + go dat "serial-message" = serialMessageCommand dat go dat x = do $logDebugS DM._LOGTAG $ T.pack $ "handled cmdrun. " ++ show x ++ ": " ++ show dat cmdRunCommand dat @@ -257,4 +262,71 @@ cmdQ <- view DM.socketQueueDomainData <$> lift ask liftIO $ STM.atomically $ STM.writeTQueue cmdQ $ DM.SocketTelnetCommand cmdDat + + +-- | +-- +serialOpenCommand :: DM.McpToolsCallRequestData -> AppContext () +serialOpenCommand dat = do + let cmdDat = DM.SerialOpenCommandData { + DM._jsonrpcSerialOpenCommandData = dat^.DM.jsonrpcMcpToolsCallRequestData + , DM._nameSerialOpenCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.nameMcpToolsCallRequestDataParams + , DM._argumentsSerialOpenCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.argumentsMcpToolsCallRequestDataParams + } + + $logDebugS DM._LOGTAG $ T.pack $ "serialOpenCommand" ++ show cmdDat + + cmdQ <- view DM.serialQueueDomainData <$> lift ask + liftIO $ STM.atomically $ STM.writeTQueue cmdQ $ DM.SerialOpenCommand cmdDat + + +-- | +-- +serialCloseCommand :: DM.McpToolsCallRequestData -> AppContext () +serialCloseCommand dat = do + let cmdDat = DM.SerialCloseCommandData { + DM._jsonrpcSerialCloseCommandData = dat^.DM.jsonrpcMcpToolsCallRequestData + } + + cmdQ <- view DM.serialQueueDomainData <$> lift ask + liftIO $ STM.atomically $ STM.writeTQueue cmdQ $ DM.SerialCloseCommand cmdDat + + +-- | +-- +serialReadCommand :: DM.McpToolsCallRequestData -> AppContext () +serialReadCommand dat = do + let cmdDat = DM.SerialReadCommandData { + DM._jsonrpcSerialReadCommandData = dat^.DM.jsonrpcMcpToolsCallRequestData + , DM._argumentsSerialReadCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.argumentsMcpToolsCallRequestDataParams + } + + cmdQ <- view DM.serialQueueDomainData <$> lift ask + liftIO $ STM.atomically $ STM.writeTQueue cmdQ $ DM.SerialReadCommand cmdDat + + +-- | +-- +serialWriteCommand :: DM.McpToolsCallRequestData -> AppContext () +serialWriteCommand dat = do + let cmdDat = DM.SerialWriteCommandData { + DM._jsonrpcSerialWriteCommandData = dat^.DM.jsonrpcMcpToolsCallRequestData + , DM._argumentsSerialWriteCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.argumentsMcpToolsCallRequestDataParams + } + + cmdQ <- view DM.serialQueueDomainData <$> lift ask + liftIO $ STM.atomically $ STM.writeTQueue cmdQ $ DM.SerialWriteCommand cmdDat + + +-- | +-- +serialMessageCommand :: DM.McpToolsCallRequestData -> AppContext () +serialMessageCommand dat = do + let cmdDat = DM.SerialMessageCommandData { + DM._jsonrpcSerialMessageCommandData = dat^.DM.jsonrpcMcpToolsCallRequestData + , DM._argumentsSerialMessageCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.argumentsMcpToolsCallRequestDataParams + } + + cmdQ <- view DM.serialQueueDomainData <$> lift ask + liftIO $ STM.atomically $ STM.writeTQueue cmdQ $ DM.SerialMessageCommand cmdDat diff --git a/src/PMS/Domain/Service/DS/Utility.hs b/src/PMS/Domain/Service/DS/Utility.hs --- a/src/PMS/Domain/Service/DS/Utility.hs +++ b/src/PMS/Domain/Service/DS/Utility.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE LambdaCase #-} module PMS.Domain.Service.DS.Utility where