pms-infra-agent-server (empty) → 0.0.1.0
raw patch · 24 files changed
+1981/−0 lines, 24 filesdep +aesondep +asyncdep +base
Dependencies added: aeson, async, base, bytestring, conduit, containers, data-default, directory, fast-logger, hspec, hspec-discover, iproute, lens, monad-logger, mtl, network, pms-domain-model, pms-infra-agent-server, process, safe-exceptions, stm, template-haskell, text, transformers
Files
- CHANGELOG.md +6/−0
- LICENSE +202/−0
- pms-infra-agent-server.cabal +96/−0
- src/PMS/Infra/Agent/Server/ApplicationBase/Control.hs +196/−0
- src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected.hs +27/−0
- src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/InternalClientDisconnected.hs +25/−0
- src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerClose.hs +46/−0
- src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerEvents.hs +40/−0
- src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerListen.hs +31/−0
- src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerRead.hs +32/−0
- src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerReadByte.hs +32/−0
- src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerStatus.hs +40/−0
- src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerWrite.hs +32/−0
- src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerWriteByte.hs +32/−0
- src/PMS/Infra/Agent/Server/ApplicationBase/State/Idle.hs +163/−0
- src/PMS/Infra/Agent/Server/ApplicationBase/State/Listening.hs +155/−0
- src/PMS/Infra/Agent/Server/CoreModel/Constant.hs +16/−0
- src/PMS/Infra/Agent/Server/CoreModel/TH.hs +130/−0
- src/PMS/Infra/Agent/Server/CoreModel/Type.hs +226/−0
- src/PMS/Infra/Agent/Server/CoreModel/Utility.hs +13/−0
- src/PMS/Infra/Agent/Server/Interface/Network.hs +43/−0
- src/PMS/Infra/Agent/Server/ProjectedContext/Core.hs +374/−0
- src/PMS/Infra/Agent/Server/ProjectedContext/Utility.hs +23/−0
- test/Spec.hs +1/−0
+ CHANGELOG.md view
@@ -0,0 +1,6 @@+# Revision history for pms-infra-agent-server++## 0.0.1.0 -- 2026-06-02++* First version.+
+ LICENSE view
@@ -0,0 +1,202 @@+ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License.
+ pms-infra-agent-server.cabal view
@@ -0,0 +1,96 @@+cabal-version: 2.4+name: pms-infra-agent-server+version: 0.0.1.0+synopsis: TCP server listener library for pty-mcp-server agent tools+description: Provides agent-server-* MCP tools: bind/listen/accept thread,+ event queue, read/write over accepted connections.+homepage: https://hackage.haskell.org/package/pty-mcp-server+bug-reports: https://github.com/phoityne/pty-mcp-server/issues+license: Apache-2.0+license-file: LICENSE+author: phoityne.hs@gmail.com+maintainer: phoityne.hs@gmail.com+copyright: 2024 phoityne.hs@gmail.com+category: System+build-type: Simple+extra-doc-files: CHANGELOG.md++common warnings++library+ import: warnings+ default-extensions: GADTs TypeFamilies+ exposed-modules:+ PMS.Infra.Agent.Server.CoreModel.Type+ PMS.Infra.Agent.Server.CoreModel.TH+ PMS.Infra.Agent.Server.CoreModel.Constant+ PMS.Infra.Agent.Server.CoreModel.Utility+ PMS.Infra.Agent.Server.Interface.Network+ PMS.Infra.Agent.Server.ProjectedContext.Core+ PMS.Infra.Agent.Server.ProjectedContext.Utility+ PMS.Infra.Agent.Server.ApplicationBase.Control+ PMS.Infra.Agent.Server.ApplicationBase.State.Idle+ PMS.Infra.Agent.Server.ApplicationBase.State.Listening+ PMS.Infra.Agent.Server.ApplicationBase.State.Connected+ PMS.Infra.Agent.Server.ApplicationBase.State.Connected.ServerListen+ PMS.Infra.Agent.Server.ApplicationBase.State.Connected.ServerRead+ PMS.Infra.Agent.Server.ApplicationBase.State.Connected.ServerWrite+ PMS.Infra.Agent.Server.ApplicationBase.State.Connected.ServerReadByte+ PMS.Infra.Agent.Server.ApplicationBase.State.Connected.ServerWriteByte+ PMS.Infra.Agent.Server.ApplicationBase.State.Connected.ServerClose+ PMS.Infra.Agent.Server.ApplicationBase.State.Connected.ServerStatus+ PMS.Infra.Agent.Server.ApplicationBase.State.Connected.ServerEvents+ PMS.Infra.Agent.Server.ApplicationBase.State.Connected.InternalClientDisconnected+ build-depends:+ base >= 4.18 && < 5,+ data-default,+ monad-logger,+ mtl,+ lens,+ text,+ safe-exceptions,+ fast-logger,+ conduit,+ bytestring,+ transformers,+ stm,+ async,+ network,+ aeson,+ containers,+ template-haskell,+ iproute,+ pms-domain-model+ hs-source-dirs: src+ default-language: Haskell2010++test-suite pms-infra-agent-server-test+ import: warnings+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-extensions: LambdaCase+ ghc-options: -Wno-missing-home-modules+ build-depends:+ base ^>=4.18.0.0,+ hspec,+ hspec-discover,+ directory,+ process,+ stm,+ async,+ aeson,+ network,+ data-default,+ lens,+ containers,+ fast-logger,+ transformers,+ bytestring,+ iproute,+ safe-exceptions,+ pms-domain-model,+ pms-infra-agent-server+ build-tool-depends:+ hspec-discover:hspec-discover
+ src/PMS/Infra/Agent/Server/ApplicationBase/Control.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}++module PMS.Infra.Agent.Server.ApplicationBase.Control where++import Control.Lens ((^.))+import Control.Monad (void)+import Control.Monad.Except (catchError, liftEither, runExceptT)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader (runReaderT)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ask)+import Control.Monad.Trans.State.Lazy (get, runStateT)+import Data.Aeson (eitherDecode)+import Data.Conduit (ConduitT, await, awaitForever, runConduit, yield, (.|))+import Data.Void (Void)+import System.Exit (ExitCode(..))+import System.IO (hPutStrLn, stderr)+import System.Log.FastLogger (TimedFastLogger)+import qualified Control.Concurrent.STM as STM+import qualified Control.Exception.Safe as E+import qualified Data.Map.Strict as Map+import qualified PMS.Domain.Model.DM.Type as DM+import qualified PMS.Domain.Model.DS.Utility as DM++import PMS.Infra.Agent.Server.CoreModel.Constant+import PMS.Infra.Agent.Server.CoreModel.TH+import PMS.Infra.Agent.Server.CoreModel.Type+import PMS.Infra.Agent.Server.ApplicationBase.State.Connected ()+import PMS.Infra.Agent.Server.ApplicationBase.State.Idle ()+import PMS.Infra.Agent.Server.ApplicationBase.State.Listening ()+import PMS.Infra.Agent.Server.Interface.Network++$(funcTH_transit)++runAppStateContext+ :: DM.DomainData+ -> AppData+ -> AppStateW+ -> TimedFastLogger+ -> AppStateContext a+ -> IO (Either DM.ErrorData (a, AppStateW))+runAppStateContext domDat appDat initSt logger ctx = do+ (result, nextSt) <-+ DM.runFastLoggerT domDat logger+ $ flip runReaderT domDat+ $ flip runReaderT appDat+ $ runStateT (runExceptT ctx) initSt+ return $ case result of+ Left e -> Left e+ Right a -> Right (a, nextSt)++run :: DM.DomainContext ()+run domDat = do+ hPutStrLn stderr "[INFO] PMS.Infra.Agent.Server.ApplicationBase.Control.run called."+ appDat <- defaultAppData defaultServerPortFunc+ runWithAppData appDat domDat++defaultAppData :: ServerPortFunc -> IO AppData+defaultAppData portFunc = AppData portFunc+ <$> STM.newTMVarIO Nothing+ <*> STM.newTMVarIO Map.empty++runWithAppData :: AppData -> DM.DomainContext ()+runWithAppData appDat domDat = do+ logDat <- DM.createLogger domDat _LOG_FILE_NAME+ runWithLogger logDat appDat domDat++runWithLogger :: (TimedFastLogger, IO ()) -> AppData -> DM.DomainContext ()+runWithLogger (logger, finalizeLogger) appDat domDat =+ flip E.catchAny exception+ $ flip E.finally finalize+ $ runAppStateContext domDat appDat (AppStateW IdleState) logger app+ >>= \case+ Right (x, _) -> return x+ Left e -> errorEnd e+ where+ finalize = do+ hPutStrLn stderr "-----------------------------------------------------------------------------"+ hPutStrLn stderr "[INFO] PMS.Infra.Agent.Server.ApplicationBase.Control.run finalize called."+ finalizeLogger+ hPutStrLn stderr "-----------------------------------------------------------------------------"++ exception e = do+ hPutStrLn stderr "-----------------------------------------------------------------------------"+ hPutStrLn stderr "[ERROR] PMS.Infra.Agent.Server.ApplicationBase.Control.run exception occurred."+ hPutStrLn stderr $ show e+ hPutStrLn stderr "-----------------------------------------------------------------------------"+ E.throwIO e++ errorEnd e = do+ hPutStrLn stderr "-----------------------------------------------------------------------------"+ hPutStrLn stderr "[ERROR] PMS.Infra.Agent.Server.ApplicationBase.Control.run end with error."+ hPutStrLn stderr $ show e+ hPutStrLn stderr "-----------------------------------------------------------------------------"++app :: AppStateContext ()+app = do+ void $ actionSW (AppStateW IdleState) (EventW EntryEvent)+ runConduit pipeline+ st <- lift get+ void $ actionSW st (EventW ExitEvent)++pipeline :: ConduitT () Void AppStateContext ()+pipeline = src .| work .| sink++src :: ConduitT () DM.AgentServerCommand AppStateContext ()+src = do+ domDat <- lift (lift (lift (lift ask)))+ let queue = domDat^.DM.agentServerQueueDomainData+ cmd <- liftIO $ STM.atomically $ STM.readTQueue queue+ yield cmd+ src++work :: ConduitT DM.AgentServerCommand EventW AppStateContext ()+work = awaitForever $ \cmd ->+ flip catchError (errHdl cmd) $ do+ ev <- lift (toEventW cmd)+ yield ev+ where+ errHdl :: DM.AgentServerCommand+ -> DM.ErrorData+ -> ConduitT DM.AgentServerCommand EventW AppStateContext ()+ errHdl cmd msg = do+ let jsonRpc = DM.getJsonRpcAgentServerCommand cmd+ lift $ errorToolsCallResponse jsonRpc msg++toEventW :: DM.AgentServerCommand -> AppStateContext EventW+toEventW (DM.AgentServerListenCommand dat) = do+ params <- liftEither $ eitherDecode $ DM.unRawJsonByteString+ $ dat^.DM.argumentsAgentServerListenCommandData+ return $ EventW $ ServerListenEvent+ $ ServerListenEventData (dat^.DM.jsonrpcAgentServerListenCommandData) params+toEventW (DM.AgentServerCloseCommand dat) =+ return $ EventW $ ServerCloseEvent+ $ ServerCloseEventData (dat^.DM.jsonrpcAgentServerCloseCommandData)+toEventW (DM.AgentServerStatusCommand dat) =+ return $ EventW $ ServerStatusEvent+ $ ServerStatusEventData (dat^.DM.jsonrpcAgentServerStatusCommandData)+toEventW (DM.AgentServerEventsCommand dat) = do+ params <- liftEither $ eitherDecode $ DM.unRawJsonByteString+ $ dat^.DM.argumentsAgentServerEventsCommandData+ return $ EventW $ ServerEventsEvent+ $ ServerEventsEventData (dat^.DM.jsonrpcAgentServerEventsCommandData) params+toEventW (DM.AgentServerReadCommand dat) =+ return $ EventW $ ServerReadEvent+ $ ServerReadEventData (dat^.DM.jsonrpcAgentServerReadCommandData)+toEventW (DM.AgentServerWriteCommand dat) = do+ params <- liftEither $ eitherDecode $ DM.unRawJsonByteString+ $ dat^.DM.argumentsAgentServerWriteCommandData+ return $ EventW $ ServerWriteEvent+ $ ServerWriteEventData (dat^.DM.jsonrpcAgentServerWriteCommandData) params+toEventW (DM.AgentServerReadByteCommand dat) =+ return $ EventW $ ServerReadByteEvent+ $ ServerReadByteEventData (dat^.DM.jsonrpcAgentServerReadByteCommandData)+toEventW (DM.AgentServerWriteByteCommand dat) = do+ params <- liftEither $ eitherDecode $ DM.unRawJsonByteString+ $ dat^.DM.argumentsAgentServerWriteByteCommandData+ return $ EventW $ ServerWriteByteEvent+ $ ServerWriteByteEventData (dat^.DM.jsonrpcAgentServerWriteByteCommandData) params+toEventW (DM.AgentServerInternalClientConnectedCommand dat) =+ return $ EventW $ InternalClientConnectedEvent+ $ InternalClientConnectedEventData+ (dat^.DM.handleNameAgentServerInternalClientConnectedCommandData)+ (dat^.DM.remoteAddrAgentServerInternalClientConnectedCommandData)+toEventW (DM.AgentServerInternalClientDisconnectedCommand _) =+ return $ EventW $ InternalClientDisconnectedEvent+ $ InternalClientDisconnectedEventData++errorToolsCallResponse :: DM.JsonRpcRequest -> DM.ErrorData -> AppStateContext ()+errorToolsCallResponse jsonRpc msg = do+ domDat <- lift (lift (lift ask))+ let resQ = domDat^.DM.responseQueueDomainData+ liftIO $ DM.toolsCallResponse resQ jsonRpc (ExitFailure 1) "" msg++sink :: ConduitT EventW Void AppStateContext ()+sink = await >>= \case+ Nothing -> return ()+ Just ev -> flip catchError errHdl $ do+ lift (go ev)+ sink+ where+ errHdl :: DM.ErrorData -> ConduitT EventW Void AppStateContext ()+ errHdl msg = do+ msg `seq` return ()+ sink++ go :: EventW -> AppStateContext ()+ go ev = do+ st <- lift get+ result <- actionSW st ev+ case result of+ Nothing -> return ()+ Just t -> transit t
+ src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module PMS.Infra.Agent.Server.ApplicationBase.State.Connected where++import PMS.Infra.Agent.Server.ApplicationBase.State.Connected.InternalClientDisconnected ()+import PMS.Infra.Agent.Server.ApplicationBase.State.Connected.ServerClose ()+import PMS.Infra.Agent.Server.ApplicationBase.State.Connected.ServerEvents ()+import PMS.Infra.Agent.Server.ApplicationBase.State.Connected.ServerListen (connectedServerListen)+import PMS.Infra.Agent.Server.ApplicationBase.State.Connected.ServerRead ()+import PMS.Infra.Agent.Server.ApplicationBase.State.Connected.ServerReadByte ()+import PMS.Infra.Agent.Server.ApplicationBase.State.Connected.ServerStatus ()+import PMS.Infra.Agent.Server.ApplicationBase.State.Connected.ServerWrite ()+import PMS.Infra.Agent.Server.ApplicationBase.State.Connected.ServerWriteByte ()+import PMS.Infra.Agent.Server.CoreModel.TH+import PMS.Infra.Agent.Server.CoreModel.Type++instanceTH_IAppState ''ConnectedStateData++instance IStateActivity ConnectedStateData EntryEventData+instance IStateActivity ConnectedStateData ExitEventData+instance IStateActivity ConnectedStateData TransitEventData+instance IStateActivity ConnectedStateData ServerListenEventData where+ action = connectedServerListen++instance IStateActivity ConnectedStateData InternalClientConnectedEventData
+ src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/InternalClientDisconnected.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module PMS.Infra.Agent.Server.ApplicationBase.State.Connected.InternalClientDisconnected where++import Control.Monad.IO.Class (liftIO)+import System.IO (hPutStrLn, stderr)++import PMS.Infra.Agent.Server.CoreModel.Type+import PMS.Infra.Agent.Server.ProjectedContext.Core+ ( runProjectedContext+ , serverCloseConnection+ )++instance IStateActivity ConnectedStateData InternalClientDisconnectedEventData where+ action = connectedInternalClientDisconnected++-- | Handle InternalClientDisconnected in the Connected state.+-- Clears the ConnCtx map entry and transitions back to Listening.+connectedInternalClientDisconnected :: AppState ConnectedStateData -> Event InternalClientDisconnectedEventData -> AppStateContext (Maybe StateTransition)+connectedInternalClientDisconnected _ (InternalClientDisconnectedEvent InternalClientDisconnectedEventData) = do+ liftIO $ hPutStrLn stderr "[INFO] client disconnected, clearing ConnCtx and returning to Listening state."+ -- Clear the ConnCtx map entry so serverStatus reflects the correct state.+ _ <- runProjectedContext serverCloseConnection+ return (Just ConnectedToListening)
+ src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerClose.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++module PMS.Infra.Agent.Server.ApplicationBase.State.Connected.ServerClose where++import Control.Lens ((^.))+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Logger (logInfoS)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ask)+import System.Exit (ExitCode(..))+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.Infra.Agent.Server.CoreModel.Type+import PMS.Infra.Agent.Server.ProjectedContext.Core+ ( runProjectedContext+ , serverCloseConnection+ )++instance IStateActivity ConnectedStateData ServerCloseEventData where+ action = serverClose++serverClose :: AppState ConnectedStateData -> Event ServerCloseEventData -> AppStateContext (Maybe StateTransition)+serverClose _ (ServerCloseEvent (ServerCloseEventData jsonRpc)) = do+ $logInfoS DM._LOGTAG "serverClose: called."+ result <- runProjectedContext serverCloseConnection+ case result of+ Left err -> do+ $logInfoS DM._LOGTAG $ T.pack $ "serverClose: failed. " ++ err+ sendServerCloseResponse jsonRpc (ExitFailure 1) "" err+ return noStateTransition+ Right () -> do+ $logInfoS DM._LOGTAG "serverClose: connection closed. transitioning to Listening."+ sendServerCloseResponse jsonRpc ExitSuccess "connection closed." ""+ return (Just ConnectedToListening)++sendServerCloseResponse :: DM.JsonRpcRequest -> ExitCode -> String -> String -> AppStateContext ()+sendServerCloseResponse jsonRpc code outStr errStr = do+ domDat <- lift (lift (lift ask))+ let resQ = domDat^.DM.responseQueueDomainData+ liftIO $ DM.toolsCallResponse resQ jsonRpc code outStr errStr
+ src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerEvents.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module PMS.Infra.Agent.Server.ApplicationBase.State.Connected.ServerEvents where++import Control.Lens ((^.))+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ask)+import System.Exit (ExitCode(..))+import qualified PMS.Domain.Model.DM.Type as DM+import qualified PMS.Domain.Model.DS.Utility as DM++import PMS.Infra.Agent.Server.CoreModel.Type+import PMS.Infra.Agent.Server.ProjectedContext.Core+ ( runProjectedContext+ , serverEvents+ , formatEvents+ )++instance IStateActivity ConnectedStateData ServerEventsEventData where+ action = connectedServerEvents++-- | Handle agent-server-events in the Connected state.+connectedServerEvents :: AppState ConnectedStateData -> Event ServerEventsEventData -> AppStateContext (Maybe StateTransition)+connectedServerEvents _ (ServerEventsEvent (ServerEventsEventData jsonRpc params)) = do+ result <- runProjectedContext (serverEvents params)+ case result of+ Left err -> do+ sendConnectedEventsResponse jsonRpc (ExitFailure 1) "" err+ return noStateTransition+ Right evs -> do+ sendConnectedEventsResponse jsonRpc ExitSuccess (formatEvents evs) ""+ return noStateTransition++sendConnectedEventsResponse :: DM.JsonRpcRequest -> ExitCode -> String -> String -> AppStateContext ()+sendConnectedEventsResponse jsonRpc code outStr errStr = do+ domDat <- lift (lift (lift ask))+ let resQ = domDat^.DM.responseQueueDomainData+ liftIO $ DM.toolsCallResponse resQ jsonRpc code outStr errStr
+ src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerListen.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module PMS.Infra.Agent.Server.ApplicationBase.State.Connected.ServerListen where++import Control.Lens ((^.))+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ask)+import System.Exit (ExitCode(..))+import qualified PMS.Domain.Model.DM.Type as DM+import qualified PMS.Domain.Model.DS.Utility as DM++import PMS.Infra.Agent.Server.CoreModel.Type++connectedServerListen :: AppState ConnectedStateData+ -> Event ServerListenEventData+ -> AppStateContext (Maybe StateTransition)+connectedServerListen _ (ServerListenEvent (ServerListenEventData jsonRpc _)) =+ invalidState jsonRpc "invalid state: already listening"++invalidState :: DM.JsonRpcRequest -> String -> AppStateContext (Maybe StateTransition)+invalidState jsonRpc msg = do+ sendInvalidStateResponse jsonRpc msg+ return noStateTransition++sendInvalidStateResponse :: DM.JsonRpcRequest -> String -> AppStateContext ()+sendInvalidStateResponse jsonRpc msg = do+ domDat <- lift (lift (lift ask))+ let resQ = domDat^.DM.responseQueueDomainData+ liftIO $ DM.toolsCallResponse resQ jsonRpc (ExitFailure 1) "" msg
+ src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerRead.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module PMS.Infra.Agent.Server.ApplicationBase.State.Connected.ServerRead where++import Control.Lens ((^.))+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ask)+import System.Exit (ExitCode(..))+import qualified PMS.Domain.Model.DM.Type as DM+import qualified PMS.Domain.Model.DS.Utility as DM++import PMS.Infra.Agent.Server.CoreModel.Type+import qualified PMS.Infra.Agent.Server.ProjectedContext.Core as PC++instance IStateActivity ConnectedStateData ServerReadEventData where+ action = serverRead++serverRead :: AppState ConnectedStateData -> Event ServerReadEventData -> AppStateContext (Maybe StateTransition)+serverRead _ (ServerReadEvent (ServerReadEventData jsonRpc)) = do+ result <- PC.runProjectedContext PC.serverRead+ case result of+ Left err -> sendServerReadResponse jsonRpc (ExitFailure 1) "" err+ Right outStr -> sendServerReadResponse jsonRpc ExitSuccess outStr ""+ return noStateTransition++sendServerReadResponse :: DM.JsonRpcRequest -> ExitCode -> String -> String -> AppStateContext ()+sendServerReadResponse jsonRpc code outStr errStr = do+ domDat <- lift (lift (lift ask))+ let resQ = domDat^.DM.responseQueueDomainData+ liftIO $ DM.toolsCallResponse resQ jsonRpc code outStr errStr
+ src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerReadByte.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module PMS.Infra.Agent.Server.ApplicationBase.State.Connected.ServerReadByte where++import Control.Lens ((^.))+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ask)+import System.Exit (ExitCode(..))+import qualified PMS.Domain.Model.DM.Type as DM+import qualified PMS.Domain.Model.DS.Utility as DM++import PMS.Infra.Agent.Server.CoreModel.Type+import qualified PMS.Infra.Agent.Server.ProjectedContext.Core as PC++instance IStateActivity ConnectedStateData ServerReadByteEventData where+ action = serverReadByte++serverReadByte :: AppState ConnectedStateData -> Event ServerReadByteEventData -> AppStateContext (Maybe StateTransition)+serverReadByte _ (ServerReadByteEvent (ServerReadByteEventData jsonRpc)) = do+ result <- PC.runProjectedContext PC.serverReadByte+ case result of+ Left err -> sendServerReadByteResponse jsonRpc (ExitFailure 1) "" err+ Right outStr -> sendServerReadByteResponse jsonRpc ExitSuccess outStr ""+ return noStateTransition++sendServerReadByteResponse :: DM.JsonRpcRequest -> ExitCode -> String -> String -> AppStateContext ()+sendServerReadByteResponse jsonRpc code outStr errStr = do+ domDat <- lift (lift (lift ask))+ let resQ = domDat^.DM.responseQueueDomainData+ liftIO $ DM.toolsCallResponse resQ jsonRpc code outStr errStr
+ src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerStatus.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module PMS.Infra.Agent.Server.ApplicationBase.State.Connected.ServerStatus where++import Control.Lens ((^.))+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ask)+import System.Exit (ExitCode(..))+import qualified PMS.Domain.Model.DM.Type as DM+import qualified PMS.Domain.Model.DS.Utility as DM++import PMS.Infra.Agent.Server.CoreModel.Type+import PMS.Infra.Agent.Server.ProjectedContext.Core+ ( runProjectedContext+ , serverStatus+ , formatStatus+ )++instance IStateActivity ConnectedStateData ServerStatusEventData where+ action = connectedServerStatus++-- | Handle agent-server-status in the Connected state.+connectedServerStatus :: AppState ConnectedStateData -> Event ServerStatusEventData -> AppStateContext (Maybe StateTransition)+connectedServerStatus _ (ServerStatusEvent (ServerStatusEventData jsonRpc)) = do+ result <- runProjectedContext serverStatus+ case result of+ Left err -> do+ sendConnectedResponse jsonRpc (ExitFailure 1) "" err+ return noStateTransition+ Right res -> do+ sendConnectedResponse jsonRpc ExitSuccess (formatStatus res) ""+ return noStateTransition++sendConnectedResponse :: DM.JsonRpcRequest -> ExitCode -> String -> String -> AppStateContext ()+sendConnectedResponse jsonRpc code outStr errStr = do+ domDat <- lift (lift (lift ask))+ let resQ = domDat^.DM.responseQueueDomainData+ liftIO $ DM.toolsCallResponse resQ jsonRpc code outStr errStr
+ src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerWrite.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module PMS.Infra.Agent.Server.ApplicationBase.State.Connected.ServerWrite where++import Control.Lens ((^.))+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ask)+import System.Exit (ExitCode(..))+import qualified PMS.Domain.Model.DM.Type as DM+import qualified PMS.Domain.Model.DS.Utility as DM++import PMS.Infra.Agent.Server.CoreModel.Type+import qualified PMS.Infra.Agent.Server.ProjectedContext.Core as PC++instance IStateActivity ConnectedStateData ServerWriteEventData where+ action = serverWrite++serverWrite :: AppState ConnectedStateData -> Event ServerWriteEventData -> AppStateContext (Maybe StateTransition)+serverWrite _ (ServerWriteEvent (ServerWriteEventData jsonRpc params)) = do+ result <- PC.runProjectedContext (PC.serverWrite params)+ case result of+ Left err -> sendServerWriteResponse jsonRpc (ExitFailure 1) "" err+ Right () -> sendServerWriteResponse jsonRpc ExitSuccess "" ""+ return noStateTransition++sendServerWriteResponse :: DM.JsonRpcRequest -> ExitCode -> String -> String -> AppStateContext ()+sendServerWriteResponse jsonRpc code outStr errStr = do+ domDat <- lift (lift (lift ask))+ let resQ = domDat^.DM.responseQueueDomainData+ liftIO $ DM.toolsCallResponse resQ jsonRpc code outStr errStr
+ src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerWriteByte.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module PMS.Infra.Agent.Server.ApplicationBase.State.Connected.ServerWriteByte where++import Control.Lens ((^.))+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ask)+import System.Exit (ExitCode(..))+import qualified PMS.Domain.Model.DM.Type as DM+import qualified PMS.Domain.Model.DS.Utility as DM++import PMS.Infra.Agent.Server.CoreModel.Type+import qualified PMS.Infra.Agent.Server.ProjectedContext.Core as PC++instance IStateActivity ConnectedStateData ServerWriteByteEventData where+ action = serverWriteByte++serverWriteByte :: AppState ConnectedStateData -> Event ServerWriteByteEventData -> AppStateContext (Maybe StateTransition)+serverWriteByte _ (ServerWriteByteEvent (ServerWriteByteEventData jsonRpc params)) = do+ result <- PC.runProjectedContext (PC.serverWriteByte params)+ case result of+ Left err -> sendServerWriteByteResponse jsonRpc (ExitFailure 1) "" err+ Right () -> sendServerWriteByteResponse jsonRpc ExitSuccess "" ""+ return noStateTransition++sendServerWriteByteResponse :: DM.JsonRpcRequest -> ExitCode -> String -> String -> AppStateContext ()+sendServerWriteByteResponse jsonRpc code outStr errStr = do+ domDat <- lift (lift (lift ask))+ let resQ = domDat^.DM.responseQueueDomainData+ liftIO $ DM.toolsCallResponse resQ jsonRpc code outStr errStr
+ src/PMS/Infra/Agent/Server/ApplicationBase/State/Idle.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module PMS.Infra.Agent.Server.ApplicationBase.State.Idle where++import Control.Lens ((^.))+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ask)+import System.Exit (ExitCode(..))+import qualified Control.Concurrent.STM as STM+import qualified PMS.Domain.Model.DM.Type as DM+import qualified PMS.Domain.Model.DS.Utility as DM++import PMS.Infra.Agent.Server.CoreModel.TH+import PMS.Infra.Agent.Server.CoreModel.Type+import PMS.Infra.Agent.Server.ProjectedContext.Core+ ( runProjectedContext+ , runProjectedContextWithCmdQ+ , serverListen+ , serverStatus+ , serverEvents+ , formatStatus+ , formatEvents+ )++instanceTH_IAppState ''IdleStateData++instance IStateActivity IdleStateData EntryEventData+instance IStateActivity IdleStateData ExitEventData+instance IStateActivity IdleStateData TransitEventData++instance IStateActivity IdleStateData ServerListenEventData where+ action = idleServerListen++instance IStateActivity IdleStateData ServerCloseEventData where+ action = idleServerClose++instance IStateActivity IdleStateData ServerStatusEventData where+ action = idleServerStatus++instance IStateActivity IdleStateData ServerEventsEventData where+ action = idleServerEvents++instance IStateActivity IdleStateData ServerReadEventData where+ action = idleServerRead++instance IStateActivity IdleStateData ServerWriteEventData where+ action = idleServerWrite++instance IStateActivity IdleStateData ServerReadByteEventData where+ action = idleServerReadByte++instance IStateActivity IdleStateData ServerWriteByteEventData where+ action = idleServerWriteByte++instance IStateActivity IdleStateData InternalClientConnectedEventData+instance IStateActivity IdleStateData InternalClientDisconnectedEventData++-- | Handle agent-server-status in the Idle state.+-- Returns JSON-encoded ServerStatusResult (isListening=false, isConnected=false).+idleServerStatus :: AppState IdleStateData+ -> Event ServerStatusEventData+ -> AppStateContext (Maybe StateTransition)+idleServerStatus _ (ServerStatusEvent (ServerStatusEventData jsonRpc)) = do+ result <- runProjectedContext serverStatus+ case result of+ Left err -> do+ sendResponse jsonRpc (ExitFailure 1) "" err+ return noStateTransition+ Right res -> do+ sendResponse jsonRpc ExitSuccess (formatStatus res) ""+ return noStateTransition++-- | Handle agent-server-events in the Idle state.+-- No listener is active so the event queue is always empty; returns [].+idleServerEvents :: AppState IdleStateData+ -> Event ServerEventsEventData+ -> AppStateContext (Maybe StateTransition)+idleServerEvents _ (ServerEventsEvent (ServerEventsEventData jsonRpc params)) = do+ result <- runProjectedContext (serverEvents params)+ case result of+ Left err -> do+ sendResponse jsonRpc (ExitFailure 1) "" err+ return noStateTransition+ Right evs -> do+ sendResponse jsonRpc ExitSuccess (formatEvents evs) ""+ return noStateTransition++-- | Handle agent-server-listen in the Idle state.+-- Delegates to ProjectedContext.serverListen via runProjectedContextWithCmdQ.+-- Retrieves sandboxNetworks from DomainData and passes it to serverListen.+-- On success: stores ListenerCtx in AppData and transitions to Listening.+-- On failure or already-listening: sends an MCP error response and stays in Idle.+idleServerListen :: AppState IdleStateData+ -> Event ServerListenEventData+ -> AppStateContext (Maybe StateTransition)+idleServerListen _ (ServerListenEvent (ServerListenEventData jsonRpc params)) = do+ appDat <- lift (lift ask)+ -- Check whether a listener is already active.+ mCtx <- liftIO $ STM.atomically $ STM.readTMVar (appDat^.listenerCtxAppData)+ case mCtx of+ Just _ -> do+ sendResponse jsonRpc (ExitFailure 1) "" "already listening."+ return noStateTransition+ Nothing -> do+ -- Retrieve sandboxNetworks from DomainData at the ApplicationBase boundary.+ -- Only [String] is passed to ProjectedContext; DomainData is not leaked inward.+ domDat <- lift (lift (lift ask))+ let sandboxNets = domDat^.DM.sandboxNetworksDomainData+ result <- runProjectedContextWithCmdQ (serverListen params sandboxNets)+ case result of+ Left err -> do+ sendResponse jsonRpc (ExitFailure 1) "" err+ return noStateTransition+ Right listenerCtx -> do+ _ <- liftIO $ STM.atomically $+ STM.swapTMVar (appDat^.listenerCtxAppData) (Just listenerCtx)+ sendResponse jsonRpc ExitSuccess "listening." ""+ return (Just IdleToListening)++idleServerClose :: AppState IdleStateData+ -> Event ServerCloseEventData+ -> AppStateContext (Maybe StateTransition)+idleServerClose _ (ServerCloseEvent (ServerCloseEventData jsonRpc)) =+ invalidState jsonRpc "invalid state: close requires Listening or Connected"++idleServerRead :: AppState IdleStateData+ -> Event ServerReadEventData+ -> AppStateContext (Maybe StateTransition)+idleServerRead _ (ServerReadEvent (ServerReadEventData jsonRpc)) =+ invalidState jsonRpc "invalid state: not connected"++idleServerWrite :: AppState IdleStateData+ -> Event ServerWriteEventData+ -> AppStateContext (Maybe StateTransition)+idleServerWrite _ (ServerWriteEvent (ServerWriteEventData jsonRpc _)) =+ invalidState jsonRpc "invalid state: not connected"++idleServerReadByte :: AppState IdleStateData+ -> Event ServerReadByteEventData+ -> AppStateContext (Maybe StateTransition)+idleServerReadByte _ (ServerReadByteEvent (ServerReadByteEventData jsonRpc)) =+ invalidState jsonRpc "invalid state: not connected"++idleServerWriteByte :: AppState IdleStateData+ -> Event ServerWriteByteEventData+ -> AppStateContext (Maybe StateTransition)+idleServerWriteByte _ (ServerWriteByteEvent (ServerWriteByteEventData jsonRpc _)) =+ invalidState jsonRpc "invalid state: not connected"++invalidState :: DM.JsonRpcRequest -> String -> AppStateContext (Maybe StateTransition)+invalidState jsonRpc msg = do+ sendResponse jsonRpc (ExitFailure 1) "" msg+ return noStateTransition++-- | Send an MCP tools-call response to the domain response queue.+sendResponse :: DM.JsonRpcRequest -> ExitCode -> String -> String -> AppStateContext ()+sendResponse jsonRpc code outStr errStr = do+ domDat <- lift (lift (lift ask))+ let resQ = domDat^.DM.responseQueueDomainData+ liftIO $ DM.toolsCallResponse resQ jsonRpc code outStr errStr
+ src/PMS/Infra/Agent/Server/ApplicationBase/State/Listening.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE OverloadedStrings #-}+++module PMS.Infra.Agent.Server.ApplicationBase.State.Listening where++import Control.Monad.IO.Class (liftIO)+import Control.Monad.Logger (logInfoS)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ask)+import System.Exit (ExitCode(..))+import System.IO (hPutStrLn, stderr)+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 Control.Lens ((^.))++import PMS.Infra.Agent.Server.CoreModel.TH+import PMS.Infra.Agent.Server.CoreModel.Type+import PMS.Infra.Agent.Server.ProjectedContext.Core+ ( runProjectedContext+ , serverStatus+ , serverEvents+ , serverCloseListener+ , formatStatus+ , formatEvents+ )++instanceTH_IAppState ''ListeningStateData++instance IStateActivity ListeningStateData EntryEventData+instance IStateActivity ListeningStateData ExitEventData+instance IStateActivity ListeningStateData TransitEventData+instance IStateActivity ListeningStateData ServerListenEventData where+ action = listeningServerListen++instance IStateActivity ListeningStateData ServerCloseEventData where+ action = listeningServerClose++instance IStateActivity ListeningStateData ServerStatusEventData where+ action = listeningServerStatus++instance IStateActivity ListeningStateData ServerEventsEventData where+ action = listeningServerEvents++instance IStateActivity ListeningStateData ServerReadEventData where+ action = listeningServerRead++instance IStateActivity ListeningStateData ServerWriteEventData where+ action = listeningServerWrite++instance IStateActivity ListeningStateData ServerReadByteEventData where+ action = listeningServerReadByte++instance IStateActivity ListeningStateData ServerWriteByteEventData where+ action = listeningServerWriteByte++instance IStateActivity ListeningStateData InternalClientConnectedEventData where+ action = listeningInternalClientConnected++instance IStateActivity ListeningStateData InternalClientDisconnectedEventData++-- | Handle agent-server-close in the Listening state.+-- Cancels the accept thread, closes the listen socket, and transitions to Idle.+listeningServerClose :: AppState ListeningStateData -> Event ServerCloseEventData -> AppStateContext (Maybe StateTransition)+listeningServerClose _ (ServerCloseEvent (ServerCloseEventData jsonRpc)) = do+ $logInfoS DM._LOGTAG "listeningServerClose: called."+ result <- runProjectedContext serverCloseListener+ case result of+ Left err -> do+ $logInfoS DM._LOGTAG $ T.pack $ "listeningServerClose: failed. " ++ err+ sendListeningResponse jsonRpc (ExitFailure 1) "" err+ return noStateTransition+ Right () -> do+ $logInfoS DM._LOGTAG "listeningServerClose: listener closed. transitioning to Idle."+ sendListeningResponse jsonRpc ExitSuccess "listener closed." ""+ return (Just ListeningToIdle)++-- | Handle agent-server-status in the Listening state.+-- Returns JSON-encoded ServerStatusResult via MCP response.+listeningServerStatus :: AppState ListeningStateData -> Event ServerStatusEventData -> AppStateContext (Maybe StateTransition)+listeningServerStatus _ (ServerStatusEvent (ServerStatusEventData jsonRpc)) = do+ result <- runProjectedContext serverStatus+ case result of+ Left err -> do+ sendListeningResponse jsonRpc (ExitFailure 1) "" err+ return noStateTransition+ Right res -> do+ sendListeningResponse jsonRpc ExitSuccess (formatStatus res) ""+ return noStateTransition++-- | Handle agent-server-events in the Listening state.+-- Drains the event queue and returns the events as a JSON array.+listeningServerEvents :: AppState ListeningStateData -> Event ServerEventsEventData -> AppStateContext (Maybe StateTransition)+listeningServerEvents _ (ServerEventsEvent (ServerEventsEventData jsonRpc params)) = do+ result <- runProjectedContext (serverEvents params)+ case result of+ Left err -> do+ sendListeningResponse jsonRpc (ExitFailure 1) "" err+ return noStateTransition+ Right evs -> do+ sendListeningResponse jsonRpc ExitSuccess (formatEvents evs) ""+ return noStateTransition++-- | Handle InternalClientConnected in the Listening state.+-- Logs the event and transitions to Connected.+listeningInternalClientConnected :: AppState ListeningStateData -> Event InternalClientConnectedEventData -> AppStateContext (Maybe StateTransition)+listeningInternalClientConnected _ (InternalClientConnectedEvent (InternalClientConnectedEventData hdlName addr)) = do+ liftIO $ hPutStrLn stderr $ "[INFO] client connected: " ++ hdlName ++ " from " ++ addr+ return (Just ListeningToConnected)++listeningServerListen :: AppState ListeningStateData+ -> Event ServerListenEventData+ -> AppStateContext (Maybe StateTransition)+listeningServerListen _ (ServerListenEvent (ServerListenEventData jsonRpc _)) =+ invalidState jsonRpc "invalid state: already listening"++listeningServerRead :: AppState ListeningStateData+ -> Event ServerReadEventData+ -> AppStateContext (Maybe StateTransition)+listeningServerRead _ (ServerReadEvent (ServerReadEventData jsonRpc)) =+ invalidState jsonRpc "invalid state: not connected"++listeningServerWrite :: AppState ListeningStateData+ -> Event ServerWriteEventData+ -> AppStateContext (Maybe StateTransition)+listeningServerWrite _ (ServerWriteEvent (ServerWriteEventData jsonRpc _)) =+ invalidState jsonRpc "invalid state: not connected"++listeningServerReadByte :: AppState ListeningStateData+ -> Event ServerReadByteEventData+ -> AppStateContext (Maybe StateTransition)+listeningServerReadByte _ (ServerReadByteEvent (ServerReadByteEventData jsonRpc)) =+ invalidState jsonRpc "invalid state: not connected"++listeningServerWriteByte :: AppState ListeningStateData+ -> Event ServerWriteByteEventData+ -> AppStateContext (Maybe StateTransition)+listeningServerWriteByte _ (ServerWriteByteEvent (ServerWriteByteEventData jsonRpc _)) =+ invalidState jsonRpc "invalid state: not connected"++invalidState :: DM.JsonRpcRequest -> String -> AppStateContext (Maybe StateTransition)+invalidState jsonRpc msg = do+ sendListeningResponse jsonRpc (ExitFailure 1) "" msg+ return noStateTransition++-- | Send an MCP tools-call response to the domain response queue.+sendListeningResponse :: DM.JsonRpcRequest -> ExitCode -> String -> String -> AppStateContext ()+sendListeningResponse jsonRpc code outStr errStr = do+ domDat <- lift (lift (lift ask))+ let resQ = domDat^.DM.responseQueueDomainData+ liftIO $ DM.toolsCallResponse resQ jsonRpc code outStr errStr
+ src/PMS/Infra/Agent/Server/CoreModel/Constant.hs view
@@ -0,0 +1,16 @@+module PMS.Infra.Agent.Server.CoreModel.Constant where++_LOG_FILE_NAME :: String+_LOG_FILE_NAME = "pms-infra-agent-server.log"++_RECV_BUFFER_SIZE :: Int+_RECV_BUFFER_SIZE = 4096++_READ_WAIT_MSEC :: Int+_READ_WAIT_MSEC = 100++_DEFAULT_HOST :: String+_DEFAULT_HOST = "127.0.0.1"++_DEFAULT_HANDLE_NAME :: String+_DEFAULT_HANDLE_NAME = "default"
+ src/PMS/Infra/Agent/Server/CoreModel/TH.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module PMS.Infra.Agent.Server.CoreModel.TH+ ( funcTH_transit+ , instanceTH_IAppState+ ) where++import Control.Monad (when)+import Control.Monad.Except (throwError)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.State.Lazy (get)+import Language.Haskell.TH+import qualified Data.Text as T+import qualified GHC.Base+import qualified GHC.Show++import PMS.Infra.Agent.Server.CoreModel.Type+import PMS.Infra.Agent.Server.CoreModel.Utility++instanceTH_IAppState :: Name -> Q [Dec]+instanceTH_IAppState stName = do+ ns <- getGadtsContNames ''Event+ clauseList <- mapM go ns+ return [InstanceD Nothing [] (AppT (ConT ''IAppState) (ConT stName)) [FunD 'actionS clauseList]]+ where+ go n = do+ s <- newName "s"+ r <- newName "r"+ return $+ Clause+ [VarP s, ConP 'EventW [] [AsP r (RecP n [])]]+ (NormalB (AppE (AppE (VarE 'action) (VarE s)) (VarE r)))+ []++ getGadtsContNames :: Name -> Q [Name]+ getGadtsContNames n = reify n >>= \case+ TyConI (DataD _ _ _ _ cs _) -> mapM go' cs+ x -> fail $ "[ERROR] can not get data constructor. " ++ show x++ go' (GadtC [name] _ _) = return name+ go' x = fail $ "[ERROR] can not get gadts data constructor. " ++ show x++funcTH_transit :: Q [Dec]+funcTH_transit = do+ fname <- newName "transit"+ cons <- getContNames ''StateTransition+ clauses <- mapM makeClause cons++ return+ [ SigD fname (AppT (AppT ArrowT (ConT ''StateTransition)) (AppT (ConT ''AppStateContext) (TupleT 0)))+ , FunD fname clauses+ ]+ where+ getContNames :: Name -> Q [Name]+ getContNames n = reify n >>= \case+ TyConI (DataD _ _ _ _ cs _) -> mapM go cs+ x -> fail $ "[ERROR] can not get data constructor. " ++ show x++ go (NormalC x _) = return x+ go x = fail $ "[ERROR] can not get data constructor. " ++ show x++ makeClause :: Name -> Q Clause+ makeClause n = do+ x <- newName "x"+ (curSt, nextSt) <- getStName n+ let liftGet = AppE (VarE 'lift) (VarE 'get)+ return $+ Clause+ [ConP n [] []]+ ( NormalB+ ( InfixE+ (Just liftGet)+ (VarE '(GHC.Base.>>=))+ ( Just+ ( LamCaseE+ [ Match+ (ConP 'AppStateW [] [ConP curSt [] []])+ ( NormalB+ ( InfixE+ (Just (UnboundVarE 'changeTo))+ (VarE '(GHC.Base.$))+ (Just (AppE (ConE 'AppStateW) (ConE nextSt)))+ )+ )+ []+ , Match+ (ConP 'AppStateW [] [VarP x])+ ( NormalB+ ( AppE+ (VarE 'throwError)+ ( InfixE+ (Just (LitE (StringL "invalid state transition. trans:")))+ (VarE '(GHC.Base.++))+ ( Just+ ( InfixE+ (Just (AppE (VarE 'GHC.Show.show) (ConE n)))+ (VarE '(GHC.Base.++))+ ( Just+ ( InfixE+ (Just (LitE (StringL ", curSt:")))+ (VarE '(GHC.Base.++))+ (Just (AppE (VarE 'GHC.Show.show) (VarE x)))+ )+ )+ )+ )+ )+ )+ )+ []+ ]+ )+ )+ )+ )+ []++ getStName :: Name -> Q (Name, Name)+ getStName n = do+ let modName = "PMS.Infra.Agent.Server.CoreModel.Type."+ stStrs = T.splitOn "To" $ T.replace (T.pack modName) "" $ T.pack $ show n+ when (2 /= length stStrs) $+ fail $ "[ERROR] invalid StateTransition constructor. " ++ show n++ let curSt = mkName $ T.unpack $ T.pack modName `T.append` head stStrs `T.append` "State"+ nextSt = mkName $ T.unpack $ T.pack modName `T.append` last stStrs `T.append` "State"++ return (curSt, nextSt)
+ src/PMS/Infra/Agent/Server/CoreModel/Type.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}++module PMS.Infra.Agent.Server.CoreModel.Type where++import Control.Concurrent.Async (Async)+import Control.Lens (makeLenses)+import Control.Monad.Except (ExceptT)+import Control.Monad.Logger (LoggingT)+import Control.Monad.Reader (ReaderT)+import Control.Monad.Trans.State.Lazy (StateT)+import Data.Aeson.TH (Options(..), defaultOptions, deriveJSON)+import Data.Default (Default(..))+import Data.Map.Strict (Map)+import Network.Socket (Socket)+import qualified Control.Concurrent.STM as STM+import qualified PMS.Domain.Model.DM.TH as DM+import qualified PMS.Domain.Model.DM.Type as DM++data ServerPortFunc = ServerPortFunc+ { _bindListenServerPortFunc :: String -> String -> IO Socket+ , _acceptConnServerPortFunc :: Socket -> IO (Socket, String)+ , _closeSocketServerPortFunc :: Socket -> IO ()+ , _closeConnServerPortFunc :: Socket -> IO ()+ }+makeLenses ''ServerPortFunc++data ServerEvent+ = ClientConnected+ { _handleNameServerEvent :: String+ , _remoteAddrServerEvent :: String+ }+ | ClientDisconnected+ { _handleNameServerEvent :: String+ }+ | BytesReceived+ { _handleNameServerEvent :: String+ , _bytesServerEvent :: String+ }+ | ListenerStopped+ | ErrorOccurred+ { _messageServerEvent :: String+ }+ deriving (Show, Eq)+$(deriveJSON defaultOptions {fieldLabelModifier = DM.dropDataName "ServerEvent"} ''ServerEvent)+makeLenses ''ServerEvent++data ListenerCtx = ListenerCtx+ { _listenSocketListenerCtx :: Socket+ , _acceptThreadListenerCtx :: Async ()+ , _eventQueueListenerCtx :: STM.TQueue ServerEvent+ }+makeLenses ''ListenerCtx++data ConnCtx = ConnCtx+ { _socketConnCtx :: Socket+ , _recvThreadConnCtx :: Async ()+ , _recvQueueConnCtx :: STM.TQueue String+ }+makeLenses ''ConnCtx++-- | '_connCtxAppData' is managed as a 'Map' to accommodate multiple connections in the future.+-- Currently, only the "default" key is used.+data AppData = AppData+ { _portFuncAppData :: ServerPortFunc+ , _listenerCtxAppData :: STM.TMVar (Maybe ListenerCtx)+ , _connCtxAppData :: STM.TMVar (Map String ConnCtx)+ }+makeLenses ''AppData++data ServerStatusResult = ServerStatusResult+ { _isListeningServerStatusResult :: Bool+ , _isConnectedServerStatusResult :: Bool+ , _listenAddrServerStatusResult :: Maybe String+ } deriving (Show, Eq)+$(deriveJSON defaultOptions {fieldLabelModifier = DM.dropDataName "ServerStatusResult", omitNothingFields = True} ''ServerStatusResult)+makeLenses ''ServerStatusResult++data StateTransition+ = IdleToListening+ | ListeningToConnected+ | ConnectedToListening+ | ListeningToIdle+ | ConnectedToIdle+ deriving (Show, Eq)++noStateTransition :: Maybe StateTransition+noStateTransition = Nothing++data ServerListenToolParams = ServerListenToolParams+ { _hostServerListenToolParams :: Maybe String+ , _portServerListenToolParams :: String+ } deriving (Show, Read, Eq)+$(deriveJSON defaultOptions {fieldLabelModifier = DM.dropDataName "ServerListenToolParams", omitNothingFields = True} ''ServerListenToolParams)+makeLenses ''ServerListenToolParams++instance Default ServerListenToolParams where+ def = ServerListenToolParams Nothing ""++data ServerCloseToolParams = ServerCloseToolParams+ { _targetServerCloseToolParams :: Maybe String+ } deriving (Show, Read, Eq)+$(deriveJSON defaultOptions {fieldLabelModifier = DM.dropDataName "ServerCloseToolParams", omitNothingFields = True} ''ServerCloseToolParams)+makeLenses ''ServerCloseToolParams++instance Default ServerCloseToolParams where+ def = ServerCloseToolParams Nothing++data ServerStatusToolParams = ServerStatusToolParams+ deriving (Show, Read, Eq)+$(deriveJSON defaultOptions {fieldLabelModifier = DM.dropDataName "ServerStatusToolParams", omitNothingFields = True} ''ServerStatusToolParams)++instance Default ServerStatusToolParams where+ def = ServerStatusToolParams++data ServerEventsToolParams = ServerEventsToolParams+ { _maxEventsServerEventsToolParams :: Maybe Int+ } deriving (Show, Read, Eq)+$(deriveJSON defaultOptions {fieldLabelModifier = DM.dropDataName "ServerEventsToolParams", omitNothingFields = True} ''ServerEventsToolParams)+makeLenses ''ServerEventsToolParams++instance Default ServerEventsToolParams where+ def = ServerEventsToolParams Nothing+++data ServerWriteToolParams = ServerWriteToolParams+ { _dataServerWriteToolParams :: String+ , _appendNewlineServerWriteToolParams :: Maybe Bool+ } deriving (Show, Read, Eq)+$(deriveJSON defaultOptions {fieldLabelModifier = DM.dropDataName "ServerWriteToolParams", omitNothingFields = True} ''ServerWriteToolParams)+makeLenses ''ServerWriteToolParams++instance Default ServerWriteToolParams where+ def = ServerWriteToolParams "" Nothing+++data ServerWriteByteToolParams = ServerWriteByteToolParams+ { _dataServerWriteByteToolParams :: String+ } deriving (Show, Read, Eq)+$(deriveJSON defaultOptions {fieldLabelModifier = DM.dropDataName "ServerWriteByteToolParams", omitNothingFields = True} ''ServerWriteByteToolParams)+makeLenses ''ServerWriteByteToolParams++instance Default ServerWriteByteToolParams where+ def = ServerWriteByteToolParams ""++data EntryEventData = EntryEventData deriving (Show, Eq)+data ExitEventData = ExitEventData deriving (Show, Eq)+data TransitEventData = TransitEventData StateTransition deriving (Show, Eq)++data ServerListenEventData = ServerListenEventData DM.JsonRpcRequest ServerListenToolParams deriving (Show, Eq)+data ServerCloseEventData = ServerCloseEventData DM.JsonRpcRequest deriving (Show, Eq)+data ServerStatusEventData = ServerStatusEventData DM.JsonRpcRequest deriving (Show, Eq)+data ServerEventsEventData = ServerEventsEventData DM.JsonRpcRequest ServerEventsToolParams deriving (Show, Eq)+data ServerReadEventData = ServerReadEventData DM.JsonRpcRequest deriving (Show, Eq)+data ServerWriteEventData = ServerWriteEventData DM.JsonRpcRequest ServerWriteToolParams deriving (Show, Eq)+data ServerReadByteEventData = ServerReadByteEventData DM.JsonRpcRequest deriving (Show, Eq)+data ServerWriteByteEventData = ServerWriteByteEventData DM.JsonRpcRequest ServerWriteByteToolParams deriving (Show, Eq)++-- | Internal event: contains both hdlName and remoteAddr+data InternalClientConnectedEventData = InternalClientConnectedEventData String String deriving (Show, Eq)+data InternalClientDisconnectedEventData = InternalClientDisconnectedEventData deriving (Show, Eq)++data Event r where+ EntryEvent :: Event EntryEventData+ ExitEvent :: Event ExitEventData+ TransitEvent :: TransitEventData -> Event TransitEventData+ ServerListenEvent :: ServerListenEventData -> Event ServerListenEventData+ ServerCloseEvent :: ServerCloseEventData -> Event ServerCloseEventData+ ServerStatusEvent :: ServerStatusEventData -> Event ServerStatusEventData+ ServerEventsEvent :: ServerEventsEventData -> Event ServerEventsEventData+ ServerReadEvent :: ServerReadEventData -> Event ServerReadEventData+ ServerWriteEvent :: ServerWriteEventData -> Event ServerWriteEventData+ ServerReadByteEvent :: ServerReadByteEventData -> Event ServerReadByteEventData+ ServerWriteByteEvent :: ServerWriteByteEventData -> Event ServerWriteByteEventData+ InternalClientConnectedEvent :: InternalClientConnectedEventData -> Event InternalClientConnectedEventData+ InternalClientDisconnectedEvent :: InternalClientDisconnectedEventData -> Event InternalClientDisconnectedEventData++deriving instance Show r => Show (Event r)++data EventW = forall r. EventW (Event r)++data IdleStateData = IdleStateData deriving (Show)+data ListeningStateData = ListeningStateData deriving (Show)+data ConnectedStateData = ConnectedStateData deriving (Show)++data AppState s where+ IdleState :: AppState IdleStateData+ ListeningState :: AppState ListeningStateData+ ConnectedState :: AppState ConnectedStateData++deriving instance Show (AppState s)++data AppStateW = forall s. (IAppState s, Show s) => AppStateW (AppState s)++type AppStateContext =+ ExceptT DM.ErrorData+ (StateT AppStateW+ (ReaderT AppData+ (ReaderT DM.DomainData+ (LoggingT IO))))++type AppContext =+ ReaderT AppData+ (ReaderT DM.DomainData+ (ExceptT DM.ErrorData+ (LoggingT IO)))++class (Show s, Show r) => IStateActivity s r where+ action :: AppState s -> Event r -> AppStateContext (Maybe StateTransition)+ action _ (TransitEvent (TransitEventData t)) = return (Just t)+ action _ _ = return noStateTransition++class IAppState s where+ actionS :: AppState s -> EventW -> AppStateContext (Maybe StateTransition)++class IAppStateW s where+ actionSW :: s -> EventW -> AppStateContext (Maybe StateTransition)++instance IAppStateW AppStateW where+ actionSW (AppStateW a) r = actionS a r
+ src/PMS/Infra/Agent/Server/CoreModel/Utility.hs view
@@ -0,0 +1,13 @@+module PMS.Infra.Agent.Server.CoreModel.Utility where++import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.State.Lazy (get, modify)++import PMS.Infra.Agent.Server.CoreModel.Type++changeTo :: AppStateW -> AppStateContext ()+changeTo nextSt = do+ curSt <- lift get+ _ <- actionSW curSt (EventW ExitEvent)+ _ <- actionSW nextSt (EventW EntryEvent)+ lift $ modify (\_ -> nextSt)
+ src/PMS/Infra/Agent/Server/Interface/Network.hs view
@@ -0,0 +1,43 @@+module PMS.Infra.Agent.Server.Interface.Network where++import Network.Socket++import PMS.Infra.Agent.Server.CoreModel.Type++-- | Default ServerPortFunc using real network operations.+defaultServerPortFunc :: ServerPortFunc+defaultServerPortFunc = ServerPortFunc+ { _bindListenServerPortFunc = networkBindListen+ , _acceptConnServerPortFunc = networkAcceptConn+ , _closeSocketServerPortFunc = networkCloseSocket+ , _closeConnServerPortFunc = networkCloseConn+ }++-- | Bind and listen on the given host and port.+-- Returns the listening Socket on success; throws IO exception on failure.+networkBindListen :: String -> String -> IO Socket+networkBindListen host port = do+ let hints = defaultHints { addrFlags = [AI_PASSIVE], addrSocketType = Stream }+ addr:_ <- getAddrInfo (Just hints) (Just host) (Just port)+ sock <- socket (addrFamily addr) Stream defaultProtocol+ setSocketOption sock ReuseAddr 1+ bind sock (addrAddress addr)+ listen sock 1+ return sock++-- | Accept one connection on the listening socket.+-- Returns a (Socket, remote-address) pair.+networkAcceptConn :: Socket -> IO (Socket, String)+networkAcceptConn listenSock = do+ (connSock, peerAddr) <- accept listenSock+ return (connSock, show peerAddr)++-- | Close the listening socket.+networkCloseSocket :: Socket -> IO ()+networkCloseSocket = close++-- | Close the accepted connection socket.+-- Use immediate close here because agent-server-close must not wait for a peer+-- or for a recvLoop blocked in network I/O.+networkCloseConn :: Socket -> IO ()+networkCloseConn = close
+ src/PMS/Infra/Agent/Server/ProjectedContext/Core.hs view
@@ -0,0 +1,374 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}++module PMS.Infra.Agent.Server.ProjectedContext.Core where++import Control.Concurrent.Async (async, cancel)+import Control.Lens ((^.))+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ask)+import Control.Monad.IO.Class (liftIO)+import Data.Aeson (encode)+import Data.IP (AddrRange, IPv4, isMatchedTo, makeAddrRange)+import Data.Maybe (fromMaybe, isJust)+import Network.Socket (Socket)+import System.IO (hPutStrLn, stderr)+import Text.Read (readMaybe)+import qualified Control.Concurrent.STM as STM+import qualified Control.Exception.Safe as E+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Map.Strict as Map+import qualified Data.Text.Encoding as T+import qualified Data.Text as T+import qualified Network.Socket.ByteString as NS+import qualified PMS.Domain.Model.DM.Type as DM+import qualified PMS.Domain.Model.DS.Utility as DU++import PMS.Infra.Agent.Server.CoreModel.Constant+import PMS.Infra.Agent.Server.CoreModel.Type++-- | The boundary between AppStateContext and IO.+-- ProjectedContext functions have the type @AppData -> IO a@.+-- They know nothing about AppStateContext, JsonRpcRequest, or response queues.+type ProjectedContext a = AppData -> IO a++-- | Lift a ProjectedContext action into AppStateContext.+-- This is the single call boundary between ApplicationBase and ProjectedContext.+runProjectedContext :: ProjectedContext a -> AppStateContext a+runProjectedContext pc = do+ appDat <- lift (lift ask) -- ReaderT AppData layer+ liftIO (pc appDat)++-- | Lift a ProjectedContext action that also needs the domain command queue.+runProjectedContextWithCmdQ+ :: (STM.TQueue DM.AgentServerCommand -> ProjectedContext a)+ -> AppStateContext a+runProjectedContextWithCmdQ pc = do+ appDat <- lift (lift ask)+ domDat <- lift (lift (lift ask))+ let cmdQ = domDat^.DM.agentServerQueueDomainData+ liftIO (pc cmdQ appDat)++-- | Check a remote address string (e.g. "127.0.0.1:12345") against a list of+-- CIDR ranges (sandboxNetworks).+-- Returns Right () if the IP matches any range, Left error message otherwise.+-- An empty CIDR list means deny all connections (default deny-all policy).+-- IPv6 addresses are always rejected; only IPv4 CIDR ranges are supported.+checkRemoteAddr :: [String] -> String -> Either String ()+checkRemoteAddr [] _ =+ Left "connection refused: sandboxNetworks is empty."+checkRemoteAddr cidrs addr+ | isIPv6Addr addr =+ Left "connection refused: IPv6 is not supported."+ | otherwise =+ case parseIPv4 addr of+ Nothing -> Left "connection refused: failed to parse remote address."+ Just ip ->+ case parseCidrs cidrs of+ Left err -> Left err+ Right ranges ->+ if any (isMatchedTo ip) ranges+ then Right ()+ else Left $ "connection refused: " ++ show ip ++ " is outside sandboxNetworks."++-- | Return True if the address string looks like an IPv6 address (starts with '[').+isIPv6Addr :: String -> Bool+isIPv6Addr ('[':_) = True+isIPv6Addr _ = False++-- | Extract the IPv4 host part from a "host:port" string and parse it.+-- Returns Nothing if the host cannot be parsed as an IPv4 address.+parseIPv4 :: String -> Maybe IPv4+parseIPv4 addr =+ let host = reverse . drop 1 . dropWhile (/= ':') . reverse $ addr+ in if null host then Nothing else readMaybe host++-- | Parse a list of CIDR strings into AddrRange IPv4 values.+-- Returns Left with the first unparsable CIDR, or Right with all ranges.+parseCidrs :: [String] -> Either String [AddrRange IPv4]+parseCidrs = mapM parseCidr+ where+ parseCidr :: String -> Either String (AddrRange IPv4)+ parseCidr cidr = case readMaybe cidr of+ Just r -> Right r+ Nothing ->+ -- Try "a.b.c.d/n" by splitting on '/'+ case break (== '/') cidr of+ (ipStr, '/':lenStr) ->+ case (readMaybe ipStr :: Maybe IPv4, readMaybe lenStr :: Maybe Int) of+ (Just ip, Just len) -> Right (makeAddrRange ip len)+ _ -> Left $ "connection refused: failed to parse CIDR: " ++ cidr+ _ -> Left $ "connection refused: failed to parse CIDR: " ++ cidr++-- | Bind and listen on the address derived from ServerListenToolParams,+-- then start the acceptLoop in a background thread.+-- sandboxNets is the list of allowed CIDR ranges passed to acceptLoop.+-- Returns Either String ListenerCtx; Left on IO failure.+serverListen+ :: ServerListenToolParams+ -> [String] -- sandboxNetworks+ -> STM.TQueue DM.AgentServerCommand+ -> ProjectedContext (Either String ListenerCtx)+serverListen params sandboxNets cmdQ appDat = E.tryAny go >>= \case+ Left ex -> return $ Left (show ex)+ Right ctx -> return $ Right ctx+ where+ go = do+ let portFunc = appDat^.portFuncAppData+ host = fromMaybe "0.0.0.0" (params^.hostServerListenToolParams)+ port = params^.portServerListenToolParams+ sock <- _bindListenServerPortFunc portFunc host port+ evQ <- STM.newTQueueIO+ thd <- async (acceptLoop sandboxNets portFunc sock evQ cmdQ appDat)+ return $ ListenerCtx sock thd evQ++-- | Loop accepting connections on the listening socket.+-- On each accepted connection, checks the remote address against sandboxNets.+-- Rejected connections are closed at TCP level and an ErrorOccurred event is enqueued.+-- Enforces single-connection policy using the _DEFAULT_HANDLE_NAME key.+-- If "default" key is already present in the ConnCtx map, sends "busy" and closes.+-- Otherwise starts recvLoop as a background thread and enqueues InternalClientConnected.+-- On any IO exception (including socket close), enqueues ListenerStopped and exits.+acceptLoop+ :: [String]+ -> ServerPortFunc+ -> Socket+ -> STM.TQueue ServerEvent+ -> STM.TQueue DM.AgentServerCommand+ -> AppData+ -> IO ()+acceptLoop sandboxNets portFunc sock evQ cmdQ appDat = E.catchAny go onErr+ where+ go = do+ (connSock, addr) <- _acceptConnServerPortFunc portFunc sock+ case checkRemoteAddr sandboxNets addr of+ Left err -> do+ -- Reject connection at TCP level; no MCP response is sent.+ hPutStrLn stderr $ "[WARN] acceptLoop: rejected " ++ addr ++ ": " ++ err+ _closeConnServerPortFunc portFunc connSock+ STM.atomically $ STM.writeTQueue evQ (ErrorOccurred err)+ Right () -> do+ connMap <- STM.atomically $ STM.readTMVar (appDat^.connCtxAppData)+ if Map.member _DEFAULT_HANDLE_NAME connMap+ then do+ -- Reject second connection: send busy message and close.+ hPutStrLn stderr $ "[WARN] acceptLoop: busy, rejecting " ++ addr+ NS.sendAll connSock "busy\r\n"+ _closeConnServerPortFunc portFunc connSock+ else do+ rQ <- STM.newTQueueIO+ thd <- async (recvLoop connSock evQ rQ cmdQ)+ let connCtx = ConnCtx connSock thd rQ+ STM.atomically $ do+ m <- STM.takeTMVar (appDat^.connCtxAppData)+ STM.putTMVar (appDat^.connCtxAppData) (Map.insert _DEFAULT_HANDLE_NAME connCtx m)+ -- Notify ApplicationBase via the domain command queue.+ STM.atomically $ STM.writeTQueue cmdQ+ $ DM.AgentServerInternalClientConnectedCommand+ $ DM.AgentServerInternalClientConnectedCommandData _DEFAULT_HANDLE_NAME addr+ acceptLoop sandboxNets portFunc sock evQ cmdQ appDat+ onErr ex = do+ hPutStrLn stderr $ "[INFO] acceptLoop: stopped. " ++ show ex+ STM.atomically $ STM.writeTQueue evQ ListenerStopped++-- | Receive bytes from the accepted connection socket.+-- Enqueues BytesReceived to the server event queue and the per-connection+-- receive queue (rQ), and InternalClientDisconnected to the domain command+-- queue on disconnect.+recvLoop :: Socket -> STM.TQueue ServerEvent -> STM.TQueue String -> STM.TQueue DM.AgentServerCommand -> IO ()+recvLoop sock evQ rQ cmdQ = E.catchAny go onErr+ where+ go = do+ bs <- NS.recv sock _RECV_BUFFER_SIZE+ if BS.null bs+ then notify+ else do+ let hex = DU.bytesToHex bs+ STM.atomically $ do+ STM.writeTQueue evQ (BytesReceived _DEFAULT_HANDLE_NAME hex)+ STM.writeTQueue rQ hex+ recvLoop sock evQ rQ cmdQ+ onErr _ = notify+ notify = STM.atomically $ do+ STM.writeTQueue evQ (ClientDisconnected _DEFAULT_HANDLE_NAME)+ STM.writeTQueue cmdQ+ $ DM.AgentServerInternalClientDisconnectedCommand+ $ DM.AgentServerInternalClientDisconnectedCommandData _DEFAULT_HANDLE_NAME++-- | Query the current listener and connection status.+serverStatus :: ProjectedContext (Either String ServerStatusResult)+serverStatus appDat = E.tryAny go >>= \case+ Left ex -> return $ Left (show ex)+ Right r -> return $ Right r+ where+ go = do+ mCtx <- STM.atomically $ STM.readTMVar (appDat^.listenerCtxAppData)+ connMap <- STM.atomically $ STM.readTMVar (appDat^.connCtxAppData)+ return $ ServerStatusResult+ { _isListeningServerStatusResult = isJust mCtx+ , _isConnectedServerStatusResult = Map.member _DEFAULT_HANDLE_NAME connMap+ , _listenAddrServerStatusResult = Nothing+ }++-- | Drain and return queued ServerEvents (up to optional max count).+serverEvents :: ServerEventsToolParams -> ProjectedContext (Either String [ServerEvent])+serverEvents params appDat = E.tryAny go >>= \case+ Left ex -> return $ Left (show ex)+ Right xs -> return $ Right xs+ where+ go = do+ mCtx <- STM.atomically $ STM.readTMVar (appDat^.listenerCtxAppData)+ case mCtx of+ Nothing -> return []+ Just ctx -> do+ evs <- STM.atomically $ STM.flushTQueue (ctx^.eventQueueListenerCtx)+ let n = fromMaybe maxBound (params^.maxEventsServerEventsToolParams)+ return (take n evs)++-- | Cancel the accept thread, close the listen socket, and clear the ListenerCtx.+serverCloseListener :: ProjectedContext (Either String ())+serverCloseListener appDat = E.tryAny go >>= \case+ Left ex -> return $ Left (show ex)+ Right r -> return r+ where+ go = do+ hPutStrLn stderr "[INFO] serverCloseListener: start."+ mCtx <- STM.atomically $ STM.readTMVar (appDat^.listenerCtxAppData)+ case mCtx of+ Nothing -> do+ hPutStrLn stderr "[INFO] serverCloseListener: not listening."+ return $ Left "not listening"+ Just ctx -> do+ hPutStrLn stderr "[INFO] serverCloseListener: closing listen socket."+ _closeSocketServerPortFunc (appDat^.portFuncAppData) (ctx^.listenSocketListenerCtx)+ hPutStrLn stderr "[INFO] serverCloseListener: cancelling accept thread."+ cancel (ctx^.acceptThreadListenerCtx)+ hPutStrLn stderr "[INFO] serverCloseListener: clearing ListenerCtx."+ STM.atomically $ do+ _ <- STM.takeTMVar (appDat^.listenerCtxAppData)+ STM.putTMVar (appDat^.listenerCtxAppData) Nothing+ hPutStrLn stderr "[INFO] serverCloseListener: done."+ return $ Right ()++-- | Close the accepted default connection while keeping the listener alive.+-- Socket close errors are ignored (client may have already disconnected);+-- the ConnCtx map entry is always deleted to allow re-connection.+serverCloseConnection :: ProjectedContext (Either String ())+serverCloseConnection appDat = E.tryAny go >>= \case+ Left ex -> return $ Left (show ex)+ Right r -> return r+ where+ go = do+ hPutStrLn stderr "[INFO] serverCloseConnection: start."+ connMap <- STM.atomically $ STM.readTMVar (appDat^.connCtxAppData)+ case Map.lookup _DEFAULT_HANDLE_NAME connMap of+ Nothing -> do+ hPutStrLn stderr "[INFO] serverCloseConnection: not connected."+ return $ Left "not connected"+ Just ctx -> do+ hPutStrLn stderr "[INFO] serverCloseConnection: closing socket."+ E.tryAny (_closeConnServerPortFunc (appDat^.portFuncAppData) (ctx^.socketConnCtx))+ >>= \r -> case r of+ Left ex -> hPutStrLn stderr $ "[WARN] serverCloseConnection: close socket: " ++ show ex+ Right _ -> return ()+ hPutStrLn stderr "[INFO] serverCloseConnection: cancelling recv thread."+ cancel (ctx^.recvThreadConnCtx)+ hPutStrLn stderr "[INFO] serverCloseConnection: clearing ConnCtx."+ STM.atomically $ do+ m <- STM.takeTMVar (appDat^.connCtxAppData)+ STM.putTMVar (appDat^.connCtxAppData) (Map.delete _DEFAULT_HANDLE_NAME m)+ hPutStrLn stderr "[INFO] serverCloseConnection: done."+ return $ Right ()++-- | Read text from the per-connection receive queue (populated by recvLoop).+-- Takes exactly 1 chunk from rQ, decodes it as UTF-8, and returns it.+-- Waits up to _READ_WAIT_MSEC for data; returns empty string on timeout.+serverRead :: ProjectedContext (Either String String)+serverRead appDat = E.tryAny go >>= \case+ Left ex -> return $ Left (show ex)+ Right r -> return r+ where+ go = do+ connMap <- STM.atomically $ STM.readTMVar (appDat^.connCtxAppData)+ case Map.lookup _DEFAULT_HANDLE_NAME connMap of+ Nothing -> return $ Left "not connected"+ Just ctx -> do+ bs <- readFromRecvQueue (ctx^.recvQueueConnCtx) _READ_WAIT_MSEC+ return $ Right (DU.bs2strUTF8 bs)++-- | Write text to the accepted default connection socket.+serverWrite :: ServerWriteToolParams -> ProjectedContext (Either String ())+serverWrite params appDat = E.tryAny go >>= \case+ Left ex -> return $ Left (show ex)+ Right r -> return r+ where+ str = params^.dataServerWriteToolParams+ appendNewline = params^.appendNewlineServerWriteToolParams+ payload = if appendNewline == Just False then str else DU.appendCRLF str+ go = do+ connMap <- STM.atomically $ STM.readTMVar (appDat^.connCtxAppData)+ case Map.lookup _DEFAULT_HANDLE_NAME connMap of+ Nothing -> return $ Left "not connected"+ Just ctx -> do+ NS.sendAll (ctx^.socketConnCtx) (T.encodeUtf8 (T.pack payload))+ return $ Right ()++-- | Read bytes from the per-connection receive queue as uppercase hex.+-- Takes exactly 1 chunk from rQ and returns it as hex.+-- Waits up to _READ_WAIT_MSEC for data; returns empty string on timeout.+serverReadByte :: ProjectedContext (Either String String)+serverReadByte appDat = E.tryAny go >>= \case+ Left ex -> return $ Left (show ex)+ Right r -> return r+ where+ go = do+ connMap <- STM.atomically $ STM.readTMVar (appDat^.connCtxAppData)+ case Map.lookup _DEFAULT_HANDLE_NAME connMap of+ Nothing -> return $ Left "not connected"+ Just ctx -> do+ bs <- readFromRecvQueue (ctx^.recvQueueConnCtx) _READ_WAIT_MSEC+ return $ Right (DU.bytesToHex bs)++-- | Write uppercase/lowercase hex bytes to the accepted default connection socket.+serverWriteByte :: ServerWriteByteToolParams -> ProjectedContext (Either String ())+serverWriteByte params appDat = E.tryAny go >>= \case+ Left ex -> return $ Left (show ex)+ Right r -> return r+ where+ hex = params^.dataServerWriteByteToolParams+ go = do+ connMap <- STM.atomically $ STM.readTMVar (appDat^.connCtxAppData)+ case Map.lookup _DEFAULT_HANDLE_NAME connMap of+ Nothing -> return $ Left "not connected"+ Just ctx ->+ case DU.hexToBytes hex of+ Left err -> return $ Left err+ Right bs -> do+ NS.sendAll (ctx^.socketConnCtx) bs+ return $ Right ()++-- | Take exactly 1 hex-encoded chunk from the per-connection receive queue+-- and decode it to a ByteString.+-- Waits up to `tout` milliseconds for data; returns empty ByteString on timeout.+readFromRecvQueue :: STM.TQueue String -> Int -> IO BS.ByteString+readFromRecvQueue rQ tout = do+ tvar <- STM.registerDelay (tout * 1000)+ mHex <- STM.atomically $+ (Just <$> STM.readTQueue rQ)+ `STM.orElse`+ (STM.readTVar tvar >>= \expired ->+ if expired then return Nothing else STM.retry)+ case mHex of+ Nothing -> return BS.empty+ Just hex -> case DU.hexToBytes hex of+ Right bs -> return bs+ Left _ -> return BS.empty++-- | Serialize a ServerStatusResult to a JSON string.+formatStatus :: ServerStatusResult -> String+formatStatus = T.unpack . T.decodeUtf8 . BSL.toStrict . encode++-- | Serialize a list of ServerEvents to a JSON string.+formatEvents :: [ServerEvent] -> String+formatEvents = T.unpack . T.decodeUtf8 . BSL.toStrict . encode
+ src/PMS/Infra/Agent/Server/ProjectedContext/Utility.hs view
@@ -0,0 +1,23 @@+module PMS.Infra.Agent.Server.ProjectedContext.Utility where++import Control.Monad.Except (throwError)+import Control.Monad.IO.Class (liftIO)+import System.Exit (ExitCode(..))+import qualified PMS.Domain.Model.DM.Type as DM++import PMS.Infra.Agent.Server.CoreModel.Type++liftIOE :: IO a -> AppContext a+liftIOE = liftIO++errorToolsCallResponse :: DM.JsonRpcRequest -> String -> AppContext ()+errorToolsCallResponse jsonRpc msg = do+ _ <- jsonRpc `seq` msg `seq` return ()+ throwError msg++toolsCallError :: DM.JsonRpcRequest -> String -> IO ()+toolsCallError jsonRpc msg =+ jsonRpc `seq` msg `seq` return ()++exitFailureCode :: ExitCode+exitFailureCode = ExitFailure 1
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}