pms-domain-service (empty) → 0.0.1.0
raw patch · 19 files changed
+1495/−0 lines, 19 filesdep +aesondep +asyncdep +base
Dependencies added: aeson, async, base, bytestring, conduit, data-default, directory, fast-logger, filepath, hspec, hspec-discover, lens, monad-logger, mtl, pms-domain-model, pms-domain-service, safe-exceptions, stm, template-haskell, text, transformers, unix
Files
- CHANGELOG.md +7/−0
- LICENSE +202/−0
- README.md +23/−0
- pms-domain-service.cabal +144/−0
- src/PMS/Domain/Service/App/Control.hs +70/−0
- src/PMS/Domain/Service/DM/Constant.hs +13/−0
- src/PMS/Domain/Service/DM/TH.hs +244/−0
- src/PMS/Domain/Service/DM/Type.hs +115/−0
- src/PMS/Domain/Service/DS/Core.hs +104/−0
- src/PMS/Domain/Service/DS/State/Run.hs +174/−0
- src/PMS/Domain/Service/DS/State/Start.hs +68/−0
- src/PMS/Domain/Service/DS/State/Start/Disconnect.hs +12/−0
- src/PMS/Domain/Service/DS/State/Start/Init.hs +41/−0
- src/PMS/Domain/Service/DS/State/Start/Launch.hs +13/−0
- src/PMS/Domain/Service/DS/State/Start/Terminate.hs +13/−0
- src/PMS/Domain/Service/DS/State/Stop.hs +73/−0
- src/PMS/Domain/Service/DS/Utility.hs +76/−0
- test/PMS/Domain/Service/App/ControlSpec.hs +102/−0
- test/Spec.hs +1/−0
+ CHANGELOG.md view
@@ -0,0 +1,7 @@+# Revision history for pms-domain-service++## 0.0.1.0 -- 2025-05-31++* 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.
+ README.md view
@@ -0,0 +1,23 @@+# pms-domain-service++`pms-domain-service` is one of the internal packages that make up the [`pty-mcp-server`](https://github.com/phoityne/pty-mcp-server) project. +It defines the state-managed core application logic, serving as the foundation of the system’s behavior and lifecycle management.++This package models the application as an explicit state machine, where domain operations are defined in terms of transitions between well-typed states. +To achieve this, it leverages Generalized Algebraic Data Types (GADTs) to encode state transitions and enforce correctness at the type level.++The design enables the domain to maintain strict control over valid operations, lifecycle invariants, and business rules. +Though it follows the State Pattern in structure, the emphasis is on ensuring a predictable, evolvable, and verifiable control flow within the domain.++By isolating this logic from UI and infrastructure concerns, `pms-domain-service` functions as the core domain layer, managing the internal state of the application in a controlled and testable manner.++---++## Package Structure++---++## Module Structure+++---
+ pms-domain-service.cabal view
@@ -0,0 +1,144 @@+cabal-version: 3.12+-- The cabal-version field refers to the version of the .cabal specification,+-- and can be different from the cabal-install (the tool) version and the+-- Cabal (the library) version you are using. As such, the Cabal (the library)+-- version used must be equal or greater than the version stated in this field.+-- Start from the specification version 2.2, the cabal-version field must be+-- the first thing in the cabal file.++-- Initial package description 'pms-domain-service' generated by+-- 'cabal init'. For further documentation, see:+-- http://haskell.org/cabal/users-guide/+--+-- The name of the package.+name: pms-domain-service++-- The package version.+-- See the Haskell package versioning policy (PVP) for standards+-- guiding when and how versions should be incremented.+-- https://pvp.haskell.org+-- PVP summary: +-+------- breaking API changes+-- | | +----- non-breaking API additions+-- | | | +--- code changes with no API change+version: 0.0.1.0++-- A short (one-line) description of the package.+synopsis: pms-domain-service++-- A longer description of the package.+description: README.md++-- The license under which the package is released.+license: Apache-2.0++-- The file containing the license text.+license-file: LICENSE++-- The package author(s).+author: phoityne.hs@gmail.com++-- An email address to which users can send suggestions, bug reports, and patches.+maintainer: phoityne.hs@gmail.com++-- A copyright notice.+copyright: 2025-2026 phoityne.hs@gmail.com+category: AI+build-type: Simple+homepage: https://github.com/phoityne/pms-domain-service+bug-reports: https://github.com/phoityne/pms-domain-service/issues++-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README.+extra-doc-files: README.md,+ CHANGELOG.md++-- Extra source files to be distributed with the package, such as examples, or a tutorial module.+-- extra-source-files:++library+ -- Import common warning flags.+ ghc-options: -Wall -Wno-orphans -Wno-x-partial -Wno-gadt-mono-local-binds++ -- Modules exported by the library.+ exposed-modules: PMS.Domain.Service.DM.Type,+ PMS.Domain.Service.DM.Constant,+ PMS.Domain.Service.App.Control,+ PMS.Domain.Service.DS.Core,+ PMS.Domain.Service.DM.TH,+ PMS.Domain.Service.DS.Utility,+ PMS.Domain.Service.DS.State.Run,+ PMS.Domain.Service.DS.State.Start,+ PMS.Domain.Service.DS.State.Start.Disconnect,+ PMS.Domain.Service.DS.State.Start.Init,+ PMS.Domain.Service.DS.State.Start.Launch,+ PMS.Domain.Service.DS.State.Start.Terminate,+ PMS.Domain.Service.DS.State.Stop++ -- Modules included in this library but not exported.+ -- other-modules:++ -- LANGUAGE extensions used by modules in this package.+ -- other-extensions:++ -- Other library packages from which modules are imported.+ build-depends: base ^>=4.21.0.0,+ transformers,+ mtl,+ text,+ template-haskell,+ monad-logger,+ fast-logger,+ safe-exceptions,+ lens,+ bytestring,+ conduit,+ data-default,+ stm,+ filepath,+ directory,+ aeson,+ pms-domain-model++ -- Directories containing source files.+ hs-source-dirs: src++ -- Base language which the package is written in.+ default-language: GHC2021+ default-extensions: LambdaCase++test-suite pms-domain-service-test+ -- Import common warning flags.+ ghc-options: -Wall -Wno-orphans -Wno-x-partial++ -- Base language which the package is written in.+ default-language: GHC2021++ -- Modules included in this executable, other than Main.+ other-modules: PMS.Domain.Service.App.ControlSpec++ -- LANGUAGE extensions used by modules in this package.+ -- other-extensions:++ -- The interface type and version of the test suite.+ type: exitcode-stdio-1.0++ -- Directories containing source files.+ hs-source-dirs: test++ -- The entrypoint to the test suite.+ main-is: Spec.hs++ -- Test dependencies.+ build-depends: base ^>=4.21.0.0,+ hspec,+ hspec-discover,+ data-default,+ stm,+ monad-logger,+ async,+ unix,+ lens,+ pms-domain-model,+ pms-domain-service+ + build-tool-depends:+ hspec-discover:hspec-discover
+ src/PMS/Domain/Service/App/Control.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+++module PMS.Domain.Service.App.Control where++import System.IO+import qualified Control.Exception.Safe as E+import System.Log.FastLogger++import qualified PMS.Domain.Model.DM.Type as DM+import qualified PMS.Domain.Model.DS.Utility as DM++import PMS.Domain.Service.DM.Constant+import PMS.Domain.Service.DM.Type+import PMS.Domain.Service.DS.Core+import PMS.Domain.Service.DS.State.Start()+import PMS.Domain.Service.DS.State.Run()+import PMS.Domain.Service.DS.State.Stop()++import PMS.Domain.Service.DS.Utility+++-- |+--+run :: DM.DomainContext ()+run dat = do+ hPutStrLn stderr "[INFO] PMS.Domain.Service.App.Control.run called."++ let appDat = AppStateW StartState+ runWithAppData appDat dat++-- |+--+runWithAppData :: AppStateW -> DM.DomainContext ()+runWithAppData appDat domDat = do+ logDat <- DM.createLogger domDat _LOG_FILE_NAME+ runWithLogger logDat appDat domDat++-- |+--+runWithLogger :: (TimedFastLogger, IO ()) -> AppStateW -> DM.DomainContext ()+runWithLogger (logger, finalizeLogger) appDat domDat = + flip E.catchAny exception+ $ flip E.finally finalize+ $ runAppState domDat appDat logger app+ >>= \case+ Right (x, _) -> return x+ Left e -> errorEnd e++ where+ finalize = do+ hPutStrLn stderr "-----------------------------------------------------------------------------"+ hPutStrLn stderr "[INFO] PMS.Domain.Service.App.Control.run finalize called."+ finalizeLogger+ hPutStrLn stderr "-----------------------------------------------------------------------------"++ exception e = do+ hPutStrLn stderr "-----------------------------------------------------------------------------"+ hPutStrLn stderr "[ERROR] PMS.Domain.Service.App.Control.run exception occurred."+ hPutStrLn stderr $ show e+ hPutStrLn stderr "-----------------------------------------------------------------------------"+ E.throwIO e++ errorEnd e = do+ hPutStrLn stderr "-----------------------------------------------------------------------------"+ hPutStrLn stderr "[ERROR] PMS.Domain.Service.App.Control.run end with error."+ hPutStrLn stderr $ show e+ hPutStrLn stderr "-----------------------------------------------------------------------------"
+ src/PMS/Domain/Service/DM/Constant.hs view
@@ -0,0 +1,13 @@+module PMS.Domain.Service.DM.Constant where++--------------------------------------------------------------------------------+-- |+--+_LOG_FILE_NAME :: String+_LOG_FILE_NAME = "pms-domain-service.log"++-- |+--+_TOOLS_LIST_FILE :: String+_TOOLS_LIST_FILE = "tools-list.json"+
+ src/PMS/Domain/Service/DM/TH.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module PMS.Domain.Service.DM.TH (+ funcTH_transit+ , instanceTH_IAppState+ ) where++import qualified GHC.Base+import qualified GHC.Show+import qualified Control.Monad.Fail+import Control.Monad.Trans.State.Lazy+import Language.Haskell.TH+import Control.Monad+import qualified Data.Text as T++import PMS.Domain.Service.DM.Type+import PMS.Domain.Service.DS.Utility+++-- |+--+{-++> stack ghci --ghci-options=-XTemplateHaskell --ghci-options=-XQuasiQuotes+*Main> :m +Language.Haskell.TH++:{+ runQ [d|+ instance IAppState StartStateData where+ actionS s (EventW r@EntryEvent{}) = action s r+ |]+:}++[InstanceD Nothing [] (AppT (ConT Type.IAppState) (ConT Type.StartState))+ [FunD Type.doActivity+ [Clause [VarP s_8,ConP Type.EventW [AsP r_9 (RecP Type.InitEvent [])]] (NormalB (AppE (AppE (VarE Type.action) (VarE s_8)) (VarE r_9))) [],+ Clause [VarP s_10,ConP Type.EventW [AsP r_11 (RecP Type.TerminateEvent [])]] (NormalB (AppE (AppE (VarE Type.action) (VarE s_10)) (VarE r_11))) []+ ]+ ]+]++[InstanceD Nothing [] (AppT (ConT Type.IAppState) (ConT Type.StartStateData))+ [FunD Type.actionS + [Clause [VarP s_0,ConP Type.EventW [] [AsP r_1 (RecP Type.EntryEvent [])]] (NormalB (AppE (AppE (VarE Type.action) (VarE s_0)) (VarE r_1))) []+ ]+ ]+]+++:{+ runQ [d|+ data Event r where+ InitEvent :: Event InitEvent+ |]+:}++[DataD [] Event_12 [PlainTV r_14] Nothing [GadtC [InitEvent_13] [] (AppT (ConT Event_12) (ConT Type.InitEvent))] []]++-}++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++ where+ go' (GadtC [name] _ _) = return name+ go' x = fail $ "[ERROR] can not get gadts data constructor. " ++ show x+++-- |+--+{-++> stack ghci --ghci-options=-XTemplateHaskell --ghci-options=-XQuasiQuotes --ghci-options=-XLambdaCase+*Main> :m +Language.Haskell.TH++:{+ runQ [d|+ transit :: StateTransition -> AppContext ()+ transit StartToRun = get >>= \case+ AppStateW StartState -> changeTo $ AppStateW RunState+ AppStateW x -> fail $ "invalid state transition. trans:" ++ show StartToRun ++ ", curSt:" ++ show x+ transit RunToStop = get >>= \case+ AppStateW RunState -> changeTo $ AppStateW StopState+ AppStateW x -> fail $ "invalid state transition. trans:" ++ show StartToRun ++ ", curSt:" ++ show x+ |]+:}++[SigD transit_0 (AppT (AppT ArrowT (ConT Type.StateTransition)) (AppT (ConT Type.AppStateContext) (TupleT 0))),+ FunD transit_0 [+ Clause [ConP Type.StartToRun []]+ (NormalB (InfixE (Just (UnboundVarE get)) (VarE GHC.Base.>>=) (Just (LamCaseE [+ Match (ConP Type.AppStateW [ConP Type.StartState []]) (NormalB (InfixE (Just (UnboundVarE changeTo)) (VarE GHC.Base.$) (Just (AppE (ConE Type.AppStateW) (ConE Type.RunState))))) [],+ Match (ConP Type.AppStateW [VarP x_5])+ (NormalB (InfixE+ (Just (VarE GHC.Base.fail))+ (VarE GHC.Base.$)+ (Just (InfixE+ (Just (LitE (StringL "invalid state transition. trans:")))+ (VarE GHC.Base.++)+ (Just (InfixE+ (Just (AppE (VarE GHC.Show.show) (ConE Type.StartToRun)))+ (VarE GHC.Base.++)+ (Just (InfixE+ (Just (LitE (StringL ", curSt:")))+ (VarE GHC.Base.++)+ (Just (AppE (VarE GHC.Show.show) (VarE x_1)))+ ))+ ))+ ))+ )) []+ ])))) [],+ Clause [+ ConP Type.RunToStop []] (NormalB (InfixE (Just (UnboundVarE get)) (VarE GHC.Base.>>=) (Just (LamCaseE [+ Match (ConP Type.AppStateW [ConP Type.RunState []]) (NormalB (InfixE (Just (UnboundVarE changeTo)) (VarE GHC.Base.$) (Just (AppE (ConE Type.AppStateW) (ConE Type.StopState))))) [],+ Match (VarP x_2) (NormalB (InfixE (Just (VarE GHC.Base.fail)) (VarE GHC.Base.$) (Just (InfixE (Just (LitE (StringL "invalid state transition. trans:"))) (VarE GHC.Base.++) (Just (InfixE (Just (AppE (VarE GHC.Show.show) (ConE Type.StartToRun))) (VarE GHC.Base.++) (Just (InfixE (Just (LitE (StringL ", curSt:"))) (VarE GHC.Base.++) (Just (AppE (VarE GHC.Show.show) (VarE x_2))))))))))) []])))) []]]+ ]+]++[SigD transit_2 (AppT (AppT ArrowT (ConT Type.StateTransition)) (AppT (ConT Type.AppContext) (TupleT 0))),+ FunD transit_2 [+ Clause [ConP Type.StartToRun [] []]+ (NormalB (InfixE (Just (VarE Control.Monad.Trans.State.Lazy.get)) (VarE GHC.Internal.Base.>>=) (Just (LamCaseE [+ Match (ConP Type.AppStateW [] [ConP Type.StartState [] []]) (NormalB (InfixE (Just (UnboundVarE changeTo)) (VarE GHC.Internal.Base.$) (Just (AppE (ConE Type.AppStateW) (ConE Type.RunState))))) [],+ Match (ConP Type.AppStateW [] [VarP x_3])+ (NormalB (InfixE + (Just (VarE GHC.Internal.Control.Monad.Fail.fail))+ (VarE GHC.Internal.Base.$) + (Just (InfixE+ (Just (LitE (StringL "invalid state transition. trans:")))+ (VarE GHC.Internal.Base.++)+ (Just (InfixE + (Just (AppE (VarE GHC.Internal.Show.show) (ConE Type.StartToRun))) + (VarE GHC.Internal.Base.++)+ (Just (InfixE (Just (LitE (StringL ", curSt:")))+ (VarE GHC.Internal.Base.++)+ (Just (AppE (VarE GHC.Internal.Show.show) (VarE x_3)))+ ))+ ))+ ))+ )) []+ ])))) [],+ Clause [ConP Type.RunToStop [] []] (NormalB (InfixE (Just (VarE Control.Monad.Trans.State.Lazy.get)) (VarE GHC.Internal.Base.>>=) (Just (LamCaseE [+ Match (ConP Type.AppStateW [] [ConP Type.RunState [] []]) (NormalB (InfixE (Just (UnboundVarE changeTo)) (VarE GHC.Internal.Base.$) (Just (AppE (ConE Type.AppStateW) (ConE Type.StopState))))) [],+ Match (ConP Type.AppStateW [] [VarP x_4]) (NormalB (InfixE (Just (VarE GHC.Internal.Control.Monad.Fail.fail)) (VarE GHC.Internal.Base.$) (Just (InfixE (Just (LitE (StringL "invalid state transition. trans:"))) (VarE GHC.Internal.Base.++) (Just (InfixE (Just (AppE (VarE GHC.Internal.Show.show) (ConE Type.StartToRun))) (VarE GHC.Internal.Base.++) (Just (InfixE (Just (LitE (StringL ", curSt:"))) (VarE GHC.Internal.Base.++) (Just (AppE (VarE GHC.Internal.Show.show) (VarE x_4))))))))))) []])))) []+ ]+]+++-}++funcTH_transit :: Q [Dec]+funcTH_transit = do+ fname <- newName "transit"+ cons <- getContNames ''StateTransition+ clauses <- mapM makeClaues 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++ where+ go (NormalC x _) = return x+ go x = fail $ "[ERROR] can not get data constructor. " ++ show x++ -- |+ --+ makeClaues :: Name -> Q Clause+ makeClaues n = do+ x <- newName "x"+ (curSt, nexSt) <- getStName n+ return $ Clause+ [ConP n [] []]+ (NormalB+ (InfixE (Just (UnboundVarE 'get)) (VarE '(GHC.Base.>>=))+ (Just (LamCaseE [+ Match (ConP 'AppStateW [] [ConP curSt [] []])+ (NormalB (InfixE (Just (UnboundVarE 'changeTo)) (VarE '(GHC.Base.$)) (Just (AppE (ConE 'AppStateW) (ConE nexSt))) )) [],+ Match (ConP 'AppStateW [] [VarP x])+ (NormalB (InfixE+ (Just (VarE 'Control.Monad.Fail.fail))+ (VarE '(GHC.Base.$))+ (Just (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.Domain.Service.DM.Type."++ let stStrs = T.splitOn "To" $ T.replace modName "" $ T.pack $ show n+ when (2 /= length stStrs) $ fail $ "[ERROR] invalid StateTransition constructor. " ++ show n++ let curSt = mkName $ T.unpack $ modName `T.append` head stStrs `T.append` "State"+ nxtSt = mkName $ T.unpack $ modName `T.append` last stStrs `T.append` "State"++ return (curSt, nxtSt)
+ src/PMS/Domain/Service/DM/Type.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE TemplateHaskell #-}++module PMS.Domain.Service.DM.Type where++import Control.Monad.Trans.State.Lazy+import Control.Monad.Except+import Control.Monad.Logger+import Control.Monad.Reader+import qualified Data.Text as T++import qualified PMS.Domain.Model.DM.Type as DM+import qualified PMS.Domain.Model.DM.Constant as DM+++--------------------------------------------------------------------------------+-- |+--+data StateTransition =+ StartToRun+ | RunToStop+ deriving (Show, Eq)++noStateTransition :: Maybe StateTransition+noStateTransition = Nothing++-- |+--+data EntryEventData = EntryEventData deriving (Show)+data ExitEventData = ExitEventData deriving (Show)+data TransitEventData = TransitEventData StateTransition deriving (Show)+-- doActibity+data InitEventData = InitEventData DM.McpInitializeRequestData deriving (Show)+data InitializedEventData = InitializedEventData DM.McpInitializedNotificationData deriving (Show)+data ToolsListEventData = ToolsListEventData DM.McpToolsListRequestData deriving (Show)+data ToolsCallEventData = ToolsCallEventData DM.McpToolsCallRequestData deriving (Show)+data LaunchEventData = LaunchEventData Int deriving (Show)+data DisconnectEventData = DisconnectEventData Int deriving (Show)+data TerminateEventData = TerminateEventData Int deriving (Show)++-- |+--+data Event r where+ EntryEvent :: Event EntryEventData+ ExitEvent :: Event ExitEventData+ TransitEvent :: TransitEventData -> Event TransitEventData+ -- doActibity+ InitEvent :: InitEventData -> Event InitEventData+ InitializedEvent :: InitializedEventData -> Event InitializedEventData+ ToolsListEvent :: ToolsListEventData -> Event ToolsListEventData+ ToolsCallEvent :: ToolsCallEventData -> Event ToolsCallEventData+ LaunchEvent :: LaunchEventData -> Event LaunchEventData+ DisconnectEvent :: DisconnectEventData -> Event DisconnectEventData+ TerminateEvent :: TerminateEventData -> Event TerminateEventData++deriving instance Show r => Show (Event r)++-- |+--+data EventW = forall r. EventW (Event r)+++++--------------------------------------------------------------------------------+-- Type for Domain Service.+--------------------------------------------------------------------------------+-- |+--+type AppStateContext = StateT AppStateW (ReaderT DM.DomainData (ExceptT DM.ErrorData (LoggingT IO)))+type AppContext = AppStateContext++-- type AppStateContext = StateT AppStateW IO++-- |+--+data StartStateData = StartStateData deriving (Show)+data RunStateData = RunStateData deriving (Show)+data StopStateData = StopStateData deriving (Show)+data AppState s where+ StartState :: AppState StartStateData+ RunState :: AppState RunStateData+ StopState :: AppState StopStateData++deriving instance Show s => Show (AppState s)++-- |+--+data AppStateW = forall s. (IAppState s, Show s) => AppStateW (AppState s)+++-- |+--+class (Show s, Show r) => IStateActivity s r where+ action :: (AppState s) -> (Event r) -> AppStateContext (Maybe StateTransition)+ action s (TransitEvent (TransitEventData t)) = do+ $logDebugS DM._LOGTAG $ T.pack $ show s ++ " " ++ show t ++ " will transit."+ return (Just t)+ action s r = do+ $logDebugS DM._LOGTAG $ T.pack $ show s ++ " " ++ show r ++ " not supported. will do nothing."+ return Nothing++-- |+--+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/Domain/Service/DS/Core.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}++module PMS.Domain.Service.DS.Core where++import Control.Monad.Logger+import Data.Conduit+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Lens+import Control.Monad.Reader+import qualified Control.Concurrent.STM as STM+import Control.Monad.Trans.State.Lazy+import qualified Data.Text as T+import Control.Monad.Except++import qualified PMS.Domain.Model.DM.Type as DM+import qualified PMS.Domain.Model.DM.Constant as DM++import PMS.Domain.Service.DM.Type+import PMS.Domain.Service.DM.TH+import PMS.Domain.Service.DS.State.Start()+import PMS.Domain.Service.DS.State.Run()+import PMS.Domain.Service.DS.State.Stop()++-- |+--+funcTH_transit+++-- |+--+app :: AppContext ()+app = do+ $logDebugS DM._LOGTAG "app called."+ runConduit pipeline+ where+ pipeline :: ConduitM () Void AppContext ()+ pipeline = src .| work .| sink++---------------------------------------------------------------------------------+-- |+--+src :: ConduitT () DM.McpRequest AppContext ()+src = lift go >>= yield >> src+ where+ go :: AppContext DM.McpRequest+ go = do+ queue <- view DM.requestQueueDomainData <$> lift ask+ req <- liftIO $ STM.atomically $ STM.readTQueue queue+ $logDebugS DM._LOGTAG $ T.pack $ "src: req: " ++ show req+ return req++---------------------------------------------------------------------------------+-- |+--+work :: ConduitT DM.McpRequest EventW AppContext ()+work = await >>= \case+ Just reqBS -> flip catchError errHdl $+ lift (go reqBS) >>= yield >> work+ Nothing -> do+ $logWarnS DM._LOGTAG "work: await returns nothing. skip."+ work+ where+ errHdl :: String -> ConduitT DM.McpRequest EventW AppContext ()+ errHdl msg = do+ $logWarnS DM._LOGTAG $ T.pack $ "work: exception occurred. skip. " ++ msg+ work+++ go :: DM.McpRequest -> AppContext EventW+ go req = req2ev req++-- |+--+req2ev :: DM.McpRequest -> AppContext EventW+req2ev (DM.McpInitializeRequest dat) = pure . EventW . InitEvent . InitEventData $ dat+req2ev (DM.McpInitializedNotification dat) = pure . EventW . InitializedEvent . InitializedEventData $ dat+req2ev (DM.McpToolsListRequest dat) = pure . EventW . ToolsListEvent . ToolsListEventData $ dat+req2ev (DM.McpToolsCallRequest dat) = pure . EventW . ToolsCallEvent . ToolsCallEventData $ dat++---------------------------------------------------------------------------------+-- |+--+sink :: ConduitT EventW Void AppContext ()+sink = await >>= \case+ Just ev -> flip catchError errHdl $ do+ lift (go ev) >> sink+ Nothing -> do+ $logWarnS DM._LOGTAG "sink: await returns nothing. skip."+ sink++ where+ errHdl :: String -> ConduitT EventW Void AppContext ()+ errHdl msg = do+ $logWarnS DM._LOGTAG $ T.pack $ "sink: exception occurred. skip. " ++ msg+ sink+ + go :: EventW -> AppContext ()+ go ev = get >>= flip actionSW ev >>= \case+ Nothing -> return ()+ Just st -> transit st
+ src/PMS/Domain/Service/DS/State/Run.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++module PMS.Domain.Service.DS.State.Run where+++import System.IO+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Logger+import qualified Data.Text as T+import Control.Lens+import Control.Monad.Reader+import qualified Control.Concurrent.STM as STM+import System.FilePath+import System.Exit++import qualified PMS.Domain.Model.DM.Type as DM+import qualified PMS.Domain.Model.DM.Constant as DM++import PMS.Domain.Service.DM.Type+import PMS.Domain.Service.DM.TH+import PMS.Domain.Service.DM.Constant+import qualified PMS.Domain.Service.DS.Utility as U++++instanceTH_IAppState ''RunStateData++-- |+--+instance IStateActivity RunStateData EntryEventData where+ action _ _ = do+ $logDebugS DM._LOGTAG "Run entry called."+ return Nothing++-- |+--+instance IStateActivity RunStateData ExitEventData where+ action _ _ = do+ $logDebugS DM._LOGTAG "Run exit called."+ return Nothing++-- |+--+instance IStateActivity RunStateData TransitEventData+ -- @see default implementation in Type module.++-- |+--+instance IStateActivity RunStateData InitEventData+ -- @see default implementation in Type module.++-- |+--+instance IStateActivity RunStateData LaunchEventData where+ action _ _ = do+ $logDebugS DM._LOGTAG "Run launch called."+ return Nothing++-- |+--+instance IStateActivity RunStateData DisconnectEventData where+ action _ _ = do+ $logDebugS DM._LOGTAG "Run discoonect called."+ return $ Just RunToStop++-- |+--+instance IStateActivity RunStateData TerminateEventData+ -- @see default implementation in Type module.++-- |+--+instance IStateActivity RunStateData InitializedEventData+ -- @see default implementation in Type module.++-- |+--+instance IStateActivity RunStateData ToolsListEventData where+ action s (ToolsListEvent r@(ToolsListEventData dat)) = do+ $logDebugS DM._LOGTAG "Run ToolsListEvent called."+ $logDebugS DM._LOGTAG (T.pack (show s))+ $logDebugS DM._LOGTAG (T.pack (show r))++ scriptsDir <- view DM.scriptsDirDomainData <$> lift ask++ let toolFile = scriptsDir </> _TOOLS_LIST_FILE+ cont <- U.readFile toolFile+ let result = DM.McpToolsListResponseResult $ DM.RawJsonByteString cont+ jsonRpc = dat^.DM.jsonrpcMcpToolsListRequestData+ resDat = DM.McpToolsListResponseData jsonRpc result+ res = DM.McpToolsListResponse resDat++ $logDebugS DM._LOGTAG $ T.pack $ show res++ queue <- view DM.responseQueueDomainData <$> lift ask+ liftIO $ STM.atomically $ STM.writeTQueue queue res++ return noStateTransition++-- |+--+instance IStateActivity RunStateData ToolsCallEventData where+ action _ (ToolsCallEvent (ToolsCallEventData evDat)) = do+ $logDebugS DM._LOGTAG "Run ToolsCallEvent called."++ cmd <- genCommand evDat $ evDat^.DM.paramsMcpToolsCallRequestData^.DM.nameMcpToolsCallRequestDataParams++ cmdQ <- view DM.commandQueueDomainData <$> lift ask+ liftIO $ STM.atomically $ STM.writeTQueue cmdQ cmd++ return noStateTransition+ + where+ genCommand :: DM.McpToolsCallRequestData -> String -> AppContext DM.Command+ genCommand dat "pty-connect" = genPtyConnectCommand dat+ genCommand dat "pty-bash" = genPtyConnectCommand dat+ genCommand dat "pty-ssh" = genPtyConnectCommand dat+ genCommand dat "pty-cabal" = genPtyConnectCommand dat+ genCommand dat "pty-stack" = genPtyConnectCommand dat+ genCommand dat "pty-ghci" = genPtyConnectCommand dat+ genCommand dat "pty-message" = do+ resQ <- view DM.responseQueueDomainData <$> lift ask+ let cmdDat = DM.PtyMessageCommandData {+ DM._namePtyMessageCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.nameMcpToolsCallRequestDataParams+ , DM._argumentsPtyMessageCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.argumentsMcpToolsCallRequestDataParams+ , DM._callbackPtyMessageCommandData = callback resQ+ }++ return $ DM.PtyMessageCommand cmdDat+ genCommand dat _ = do+ resQ <- view DM.responseQueueDomainData <$> lift ask+ let cmdDat = DM.SystemCommandData {+ DM._nameSystemCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.nameMcpToolsCallRequestDataParams+ , DM._argumentsSystemCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.argumentsMcpToolsCallRequestDataParams+ , DM._callbackSystemCommandData = callback resQ+ }++ return $ DM.SystemCommand cmdDat++ genPtyConnectCommand :: DM.McpToolsCallRequestData -> AppContext DM.Command+ genPtyConnectCommand dat = do+ resQ <- view DM.responseQueueDomainData <$> lift ask+ let cmdDat = DM.PtyConnectCommandData {+ DM._namePtyConnectCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.nameMcpToolsCallRequestDataParams+ , DM._argumentsPtyConnectCommandData = dat^.DM.paramsMcpToolsCallRequestData^.DM.argumentsMcpToolsCallRequestDataParams+ , DM._callbackPtyConnectCommandData = callback resQ+ }++ return $ DM.PtyConnectCommand cmdDat++ -- |+ --+ callback :: STM.TQueue DM.McpResponse -> DM.SystemCommandCallback ()+ callback resQ code outStr errStr = do+ hPutStrLn stderr $ "[INFO] PMS.Domain.Service.DS.State.Run.callback called."++ let jsonRpc = evDat^.DM.jsonrpcMcpToolsCallRequestData+ content = [ DM.McpToolsCallResponseResultContent "text" outStr+ , DM.McpToolsCallResponseResultContent "text" errStr+ ]+ result = DM.McpToolsCallResponseResult {+ DM._contentMcpToolsCallResponseResult = content+ , DM._isErrorMcpToolsCallResponseResult = (ExitSuccess /= code)+ }+ resDat = DM.McpToolsCallResponseData jsonRpc result+ res = DM.McpToolsCallResponse resDat++ STM.atomically $ STM.writeTQueue resQ res++ hPutStrLn stderr $ "[INFO] PMS.Domain.Service.DS.State.Run.callback end."
+ src/PMS/Domain/Service/DS/State/Start.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++module PMS.Domain.Service.DS.State.Start where++import Control.Monad.Logger++import qualified PMS.Domain.Model.DM.Constant as DM++import PMS.Domain.Service.DM.Type+import PMS.Domain.Service.DM.TH+import PMS.Domain.Service.DS.State.Start.Init()+import PMS.Domain.Service.DS.State.Start.Launch()+import PMS.Domain.Service.DS.State.Start.Disconnect()+import PMS.Domain.Service.DS.State.Start.Terminate()++{-+-- |+--+instance IAppState StartStateData where+ actionS s (EventW r@EntryEvent{}) = action s r+ actionS s (EventW r@ExitEvent{}) = action s r+ actionS s (EventW r@TransitEvent{}) = action s r+ actionS s (EventW r@InitEvent{}) = action s r+ actionS s (EventW r@LaunchEvent{}) = action s r+ actionS s (EventW r@DisconnectEvent{}) = action s r+ actionS s (EventW r@TerminateEvent{}) = action s r+-}+instanceTH_IAppState ''StartStateData++-- |+--+instance IStateActivity StartStateData EntryEventData where+ action _ _ = do+ $logDebugS DM._LOGTAG "Start entry called."+ return Nothing++-- |+--+instance IStateActivity StartStateData ExitEventData where+ action _ _ = do+ $logDebugS DM._LOGTAG "Start exit called."+ return Nothing++-- |+--+instance IStateActivity StartStateData TransitEventData+ -- @see default implementation in Type module.+++-- |+--+instance IStateActivity StartStateData InitializedEventData where+ action _ _ = do+ $logDebugS DM._LOGTAG "initialized called."+ return $ Just StartToRun++-- |+--+instance IStateActivity StartStateData ToolsListEventData+ -- @see default implementation in Type module.++-- |+--+instance IStateActivity StartStateData ToolsCallEventData+ -- @see default implementation in Type module.
+ src/PMS/Domain/Service/DS/State/Start/Disconnect.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module PMS.Domain.Service.DS.State.Start.Disconnect where++import PMS.Domain.Service.DM.Type++-- |+--+instance IStateActivity StartStateData DisconnectEventData+ -- @see default implementation in Type module.+
+ src/PMS/Domain/Service/DS/State/Start/Init.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}++module PMS.Domain.Service.DS.State.Start.Init where++import Data.Default+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Logger+import Control.Monad.Reader+import Control.Lens+import qualified Data.Text as T+import qualified Control.Concurrent.STM as STM++import qualified PMS.Domain.Model.DM.Type as DM+import qualified PMS.Domain.Model.DM.Constant as DM++import PMS.Domain.Service.DM.Type+++-- |+--+instance IStateActivity StartStateData InitEventData where+ action s (InitEvent r@(InitEventData dat)) = do+ $logDebugS DM._LOGTAG "Start init called."+ $logDebugS DM._LOGTAG (T.pack (show s))+ $logDebugS DM._LOGTAG (T.pack (show r))++ let jsonRpc = dat^.DM.jsonrpcMcpInitializeRequestData+ resDat = DM.McpInitializeResponseData jsonRpc def+ res = DM.McpInitializeResponse resDat++ $logDebugS DM._LOGTAG $ T.pack $ show res++ queue <- view DM.responseQueueDomainData <$> lift ask+ liftIO $ STM.atomically $ STM.writeTQueue queue res++ return Nothing+
+ src/PMS/Domain/Service/DS/State/Start/Launch.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module PMS.Domain.Service.DS.State.Start.Launch where++import PMS.Domain.Service.DM.Type+++-- |+--+instance IStateActivity StartStateData LaunchEventData+ -- @see default implementation in Type module.+
+ src/PMS/Domain/Service/DS/State/Start/Terminate.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module PMS.Domain.Service.DS.State.Start.Terminate where++import PMS.Domain.Service.DM.Type+++-- |+--+instance IStateActivity StartStateData TerminateEventData+ -- @see default implementation in Type module.+
+ src/PMS/Domain/Service/DS/State/Stop.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++module PMS.Domain.Service.DS.State.Stop where++import Control.Monad.Logger++import qualified PMS.Domain.Model.DM.Constant as DM++import PMS.Domain.Service.DM.Type+import PMS.Domain.Service.DM.TH++-- |+--+instanceTH_IAppState ''StopStateData++-- |+--+instance IStateActivity StopStateData EntryEventData where+ action _ _ = do+ $logDebugS DM._LOGTAG "Stop entry called."+ return Nothing++-- |+--+instance IStateActivity StopStateData ExitEventData where+ action _ _ = do+ $logDebugS DM._LOGTAG "Stop exit called."+ return Nothing++-- |+--+instance IStateActivity StopStateData TransitEventData+ -- @see default implementation in Type module.++-- |+--+instance IStateActivity StopStateData InitEventData+ -- @see default implementation in Type module.++-- |+--+instance IStateActivity StopStateData LaunchEventData+ -- @see default implementation in Type module.++-- |+--+instance IStateActivity StopStateData DisconnectEventData+ -- @see default implementation in Type module.++-- |+--+instance IStateActivity StopStateData TerminateEventData where+ action _ _ = do+ $logDebugS DM._LOGTAG "Stop terminate called. will exit."+ return Nothing++-- |+--+instance IStateActivity StopStateData InitializedEventData+ -- @see default implementation in Type module.++-- |+--+instance IStateActivity StopStateData ToolsListEventData+ -- @see default implementation in Type module.++-- |+--+instance IStateActivity StopStateData ToolsCallEventData+ -- @see default implementation in Type module.
+ src/PMS/Domain/Service/DS/Utility.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE OverloadedStrings #-}++module PMS.Domain.Service.DS.Utility where++import Control.Monad.Trans.State.Lazy+import Control.Monad.Except+import Control.Monad.Reader+import System.Log.FastLogger+import qualified Control.Exception.Safe as E+import qualified Data.Text.IO as T+import qualified Data.Text.Encoding as TE+import qualified Data.ByteString.Lazy as BL+import System.Directory++import qualified PMS.Domain.Model.DM.Type as DM+import qualified PMS.Domain.Model.DS.Utility as DM+import PMS.Domain.Service.DM.Type+++-- |+--+changeTo :: AppStateW -> AppStateContext ()+changeTo nextSt = do+ curSt <- get+ _ <- actionSW curSt (EventW ExitEvent)++ let req = EventW EntryEvent+ _ <- actionSW nextSt req++ modify (\_ -> nextSt)+++-- |+--+runAppState :: DM.DomainData -> AppStateW -> TimedFastLogger -> AppStateContext a -> IO (Either DM.ErrorData (a, AppStateW))+runAppState domDat st logger ctx =+ DM.runFastLoggerT domDat logger+ $ runExceptT+ $ flip runReaderT domDat+ $ runStateT ctx st++-- |+--+liftIOE :: IO a -> AppStateContext a+liftIOE f = liftIO (go f) >>= liftEither+ where+ go :: IO b -> IO (Either String b)+ go x = E.catchAny (Right <$> x) errHdl++ errHdl :: E.SomeException -> IO (Either String a)+ errHdl = return . Left . show++-- |+--+readFile :: FilePath -> AppContext BL.ByteString+readFile path = isFileExists path+ >>= isReadable+ >>= go+ where+ go f = liftIOE $ do+ cont <- T.readFile f+ return $ BL.fromStrict $ TE.encodeUtf8 cont++-- |+--+isFileExists :: FilePath -> AppContext FilePath+isFileExists f = liftIOE (doesFileExist f) >>= \case+ True -> return f+ False -> throwError $ "invalid file. not exists." ++ f++-- |+--+isReadable :: FilePath -> AppContext FilePath+isReadable f = liftIOE (readable <$> getPermissions f) >>= \case+ True -> return f+ False -> throwError $ "invalid file. not readable." ++ f
+ test/PMS/Domain/Service/App/ControlSpec.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++module PMS.Domain.Service.App.ControlSpec (spec) where++import Test.Hspec+import Control.Concurrent.Async+import qualified Control.Concurrent.STM as STM+import Control.Lens+import Data.Default++import qualified PMS.Domain.Model.DM.Type as DM+import qualified PMS.Domain.Service.App.Control as SUT+import qualified PMS.Domain.Service.DM.Type as SUT+++-- |+--+data SpecContext = SpecContext {+ _domainDataSpecContext :: DM.DomainData+ , _appDataSpecContext :: SUT.AppStateW+ }++makeLenses ''SpecContext++defaultSpecContext :: IO SpecContext+defaultSpecContext = do+ domDat <- DM.defaultDomainData+ let appDat = SUT.AppStateW SUT.StartState+ return SpecContext {+ _domainDataSpecContext = domDat+ , _appDataSpecContext = appDat+ }++-- |+--+spec :: Spec+spec = do+ runIO $ putStrLn "Start Spec."+ beforeAll setUpOnce $ + afterAll tearDownOnce . + beforeWith setUp . + after tearDown $ run+++-- |+--+setUpOnce :: IO SpecContext+setUpOnce = do+ putStrLn "[INFO] EXECUTED ONLY ONCE BEFORE ALL TESTS START."+ defaultSpecContext++-- |+--+tearDownOnce :: SpecContext -> IO ()+tearDownOnce _ = do+ putStrLn "[INFO] EXECUTED ONLY ONCE AFTER ALL TESTS FINISH."++-- |+--+setUp :: SpecContext -> IO SpecContext+setUp ctx = do+ putStrLn "[INFO] EXECUTED BEFORE EACH TEST STARTS."++ domDat <- DM.defaultDomainData+ return ctx { _domainDataSpecContext = domDat+ , _appDataSpecContext = SUT.AppStateW SUT.StartState+ }++-- |+--+tearDown :: SpecContext -> IO ()+tearDown _ = do+ putStrLn "[INFO] EXECUTED AFTER EACH TEST FINISHES."++-- |+--+run :: SpecWith SpecContext+run = do+ describe "runWithAppData" $ do+ context "when McpInitializeRequest" $ do+ it "should be initialized." $ \ctx -> do + putStrLn "[INFO] EXECUTING THE FIRST TEST."++ let domDat = ctx^.domainDataSpecContext+ appDat = ctx^.appDataSpecContext+ reqQ = domDat^.DM.requestQueueDomainData+ resQ = domDat^.DM.responseQueueDomainData+ args = DM.McpInitializeRequest def+ expect = ""+ + thId <- async $ SUT.runWithAppData appDat domDat++ STM.atomically $ STM.writeTQueue reqQ args++ (DM.McpInitializeResponse dat) <- STM.atomically $ STM.readTQueue resQ++ let actual = dat^.DM.jsonrpcMcpInitializeResponseData^.DM.jsonrpcJsonRpcRequest+ actual `shouldBe` expect++ cancel thId+
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}