diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,6 @@ +# Revision history for pms-infra-agent-server + +## 0.0.1.0 -- 2026-06-02 + +* First version. + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/pms-infra-agent-server.cabal b/pms-infra-agent-server.cabal new file mode 100644 --- /dev/null +++ b/pms-infra-agent-server.cabal @@ -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 diff --git a/src/PMS/Infra/Agent/Server/ApplicationBase/Control.hs b/src/PMS/Infra/Agent/Server/ApplicationBase/Control.hs new file mode 100644 --- /dev/null +++ b/src/PMS/Infra/Agent/Server/ApplicationBase/Control.hs @@ -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 diff --git a/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected.hs b/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected.hs new file mode 100644 --- /dev/null +++ b/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected.hs @@ -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 diff --git a/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/InternalClientDisconnected.hs b/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/InternalClientDisconnected.hs new file mode 100644 --- /dev/null +++ b/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/InternalClientDisconnected.hs @@ -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) diff --git a/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerClose.hs b/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerClose.hs new file mode 100644 --- /dev/null +++ b/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerClose.hs @@ -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 diff --git a/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerEvents.hs b/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerEvents.hs new file mode 100644 --- /dev/null +++ b/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerEvents.hs @@ -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 diff --git a/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerListen.hs b/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerListen.hs new file mode 100644 --- /dev/null +++ b/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerListen.hs @@ -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 diff --git a/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerRead.hs b/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerRead.hs new file mode 100644 --- /dev/null +++ b/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerRead.hs @@ -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 diff --git a/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerReadByte.hs b/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerReadByte.hs new file mode 100644 --- /dev/null +++ b/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerReadByte.hs @@ -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 diff --git a/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerStatus.hs b/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerStatus.hs new file mode 100644 --- /dev/null +++ b/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerStatus.hs @@ -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 diff --git a/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerWrite.hs b/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerWrite.hs new file mode 100644 --- /dev/null +++ b/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerWrite.hs @@ -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 diff --git a/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerWriteByte.hs b/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerWriteByte.hs new file mode 100644 --- /dev/null +++ b/src/PMS/Infra/Agent/Server/ApplicationBase/State/Connected/ServerWriteByte.hs @@ -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 diff --git a/src/PMS/Infra/Agent/Server/ApplicationBase/State/Idle.hs b/src/PMS/Infra/Agent/Server/ApplicationBase/State/Idle.hs new file mode 100644 --- /dev/null +++ b/src/PMS/Infra/Agent/Server/ApplicationBase/State/Idle.hs @@ -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 diff --git a/src/PMS/Infra/Agent/Server/ApplicationBase/State/Listening.hs b/src/PMS/Infra/Agent/Server/ApplicationBase/State/Listening.hs new file mode 100644 --- /dev/null +++ b/src/PMS/Infra/Agent/Server/ApplicationBase/State/Listening.hs @@ -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 diff --git a/src/PMS/Infra/Agent/Server/CoreModel/Constant.hs b/src/PMS/Infra/Agent/Server/CoreModel/Constant.hs new file mode 100644 --- /dev/null +++ b/src/PMS/Infra/Agent/Server/CoreModel/Constant.hs @@ -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" diff --git a/src/PMS/Infra/Agent/Server/CoreModel/TH.hs b/src/PMS/Infra/Agent/Server/CoreModel/TH.hs new file mode 100644 --- /dev/null +++ b/src/PMS/Infra/Agent/Server/CoreModel/TH.hs @@ -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) diff --git a/src/PMS/Infra/Agent/Server/CoreModel/Type.hs b/src/PMS/Infra/Agent/Server/CoreModel/Type.hs new file mode 100644 --- /dev/null +++ b/src/PMS/Infra/Agent/Server/CoreModel/Type.hs @@ -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 diff --git a/src/PMS/Infra/Agent/Server/CoreModel/Utility.hs b/src/PMS/Infra/Agent/Server/CoreModel/Utility.hs new file mode 100644 --- /dev/null +++ b/src/PMS/Infra/Agent/Server/CoreModel/Utility.hs @@ -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) diff --git a/src/PMS/Infra/Agent/Server/Interface/Network.hs b/src/PMS/Infra/Agent/Server/Interface/Network.hs new file mode 100644 --- /dev/null +++ b/src/PMS/Infra/Agent/Server/Interface/Network.hs @@ -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 diff --git a/src/PMS/Infra/Agent/Server/ProjectedContext/Core.hs b/src/PMS/Infra/Agent/Server/ProjectedContext/Core.hs new file mode 100644 --- /dev/null +++ b/src/PMS/Infra/Agent/Server/ProjectedContext/Core.hs @@ -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 diff --git a/src/PMS/Infra/Agent/Server/ProjectedContext/Utility.hs b/src/PMS/Infra/Agent/Server/ProjectedContext/Utility.hs new file mode 100644 --- /dev/null +++ b/src/PMS/Infra/Agent/Server/ProjectedContext/Utility.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}