{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}

module PMS.Infra.ProcSpawn.DS.Utility where

import System.IO
import Control.Lens
import System.Exit
import System.Log.FastLogger
import qualified Control.Exception.Safe as E
import Control.Monad.IO.Class
import Control.Monad.Except
import Control.Monad.Reader
import qualified Control.Concurrent.STM as STM
import qualified System.Process as S
import qualified Data.ByteString as BS
import qualified System.Environment as Env

import qualified PMS.Domain.Model.DM.Type as DM
import qualified PMS.Domain.Model.DS.Utility as DM
import PMS.Infra.ProcSpawn.DM.Type

-- |
--
runApp :: DM.DomainData -> AppData -> TimedFastLogger -> AppContext a -> IO (Either DM.ErrorData a)
runApp :: forall a.
DomainData
-> AppData
-> TimedFastLogger
-> AppContext a
-> IO (Either [Char] a)
runApp DomainData
domDat AppData
appDat TimedFastLogger
logger AppContext a
ctx =
  DomainData
-> TimedFastLogger
-> LoggingT IO (Either [Char] a)
-> IO (Either [Char] a)
forall a. DomainData -> TimedFastLogger -> LoggingT IO a -> IO a
DM.runFastLoggerT DomainData
domDat TimedFastLogger
logger
    (LoggingT IO (Either [Char] a) -> IO (Either [Char] a))
-> LoggingT IO (Either [Char] a) -> IO (Either [Char] a)
forall a b. (a -> b) -> a -> b
$ ExceptT [Char] (LoggingT IO) a -> LoggingT IO (Either [Char] a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
    (ExceptT [Char] (LoggingT IO) a -> LoggingT IO (Either [Char] a))
-> ExceptT [Char] (LoggingT IO) a -> LoggingT IO (Either [Char] a)
forall a b. (a -> b) -> a -> b
$ (ReaderT DomainData (ExceptT [Char] (LoggingT IO)) a
 -> DomainData -> ExceptT [Char] (LoggingT IO) a)
-> DomainData
-> ReaderT DomainData (ExceptT [Char] (LoggingT IO)) a
-> ExceptT [Char] (LoggingT IO) a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT DomainData (ExceptT [Char] (LoggingT IO)) a
-> DomainData -> ExceptT [Char] (LoggingT IO) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT DomainData
domDat
    (ReaderT DomainData (ExceptT [Char] (LoggingT IO)) a
 -> ExceptT [Char] (LoggingT IO) a)
-> ReaderT DomainData (ExceptT [Char] (LoggingT IO)) a
-> ExceptT [Char] (LoggingT IO) a
forall a b. (a -> b) -> a -> b
$ AppContext a
-> AppData -> ReaderT DomainData (ExceptT [Char] (LoggingT IO)) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT AppContext a
ctx AppData
appDat


-- |
--
liftIOE :: IO a -> AppContext a
liftIOE :: forall a. IO a -> AppContext a
liftIOE IO a
f = IO (Either [Char] a)
-> ReaderT
     AppData
     (ReaderT DomainData (ExceptT [Char] (LoggingT IO)))
     (Either [Char] a)
forall a. IO a -> AppContext a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> IO (Either [Char] a)
forall b. IO b -> IO (Either [Char] b)
go IO a
f) ReaderT
  AppData
  (ReaderT DomainData (ExceptT [Char] (LoggingT IO)))
  (Either [Char] a)
-> (Either [Char] a
    -> ReaderT
         AppData (ReaderT DomainData (ExceptT [Char] (LoggingT IO))) a)
-> ReaderT
     AppData (ReaderT DomainData (ExceptT [Char] (LoggingT IO))) a
forall a b.
ReaderT
  AppData (ReaderT DomainData (ExceptT [Char] (LoggingT IO))) a
-> (a
    -> ReaderT
         AppData (ReaderT DomainData (ExceptT [Char] (LoggingT IO))) b)
-> ReaderT
     AppData (ReaderT DomainData (ExceptT [Char] (LoggingT IO))) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either [Char] a
-> ReaderT
     AppData (ReaderT DomainData (ExceptT [Char] (LoggingT IO))) a
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
  where
    go :: IO b -> IO (Either String b)
    go :: forall b. IO b -> IO (Either [Char] b)
go IO b
x = IO (Either [Char] b)
-> (SomeException -> IO (Either [Char] b)) -> IO (Either [Char] b)
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
E.catchAny (b -> Either [Char] b
forall a b. b -> Either a b
Right (b -> Either [Char] b) -> IO b -> IO (Either [Char] b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO b
x) SomeException -> IO (Either [Char] b)
forall a. SomeException -> IO (Either [Char] a)
errHdl

    errHdl :: E.SomeException -> IO (Either String a)
    errHdl :: forall a. SomeException -> IO (Either [Char] a)
errHdl = Either [Char] a -> IO (Either [Char] a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] a -> IO (Either [Char] a))
-> (SomeException -> Either [Char] a)
-> SomeException
-> IO (Either [Char] a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Either [Char] a
forall a b. a -> Either a b
Left ([Char] -> Either [Char] a)
-> (SomeException -> [Char]) -> SomeException -> Either [Char] a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> [Char]
forall a. Show a => a -> [Char]
show

---------------------------------------------------------------------------------
-- |
--
toolsCallResponse :: STM.TQueue DM.McpResponse
                  -> DM.JsonRpcRequest
                  -> ExitCode
                  -> String
                  -> String
                  -> IO ()
toolsCallResponse :: TQueue McpResponse
-> JsonRpcRequest -> ExitCode -> [Char] -> [Char] -> IO ()
toolsCallResponse TQueue McpResponse
resQ JsonRpcRequest
jsonRpc ExitCode
code [Char]
outStr [Char]
errStr = do
  let content :: [McpToolsCallResponseResultContent]
content = [ [Char] -> [Char] -> McpToolsCallResponseResultContent
DM.McpToolsCallResponseResultContent [Char]
"text" [Char]
outStr
                , [Char] -> [Char] -> McpToolsCallResponseResultContent
DM.McpToolsCallResponseResultContent [Char]
"text" [Char]
errStr
                ]
      result :: McpToolsCallResponseResult
result = DM.McpToolsCallResponseResult {
                  _contentMcpToolsCallResponseResult :: [McpToolsCallResponseResultContent]
DM._contentMcpToolsCallResponseResult = [McpToolsCallResponseResultContent]
content
                , _isErrorMcpToolsCallResponseResult :: Bool
DM._isErrorMcpToolsCallResponseResult = (ExitCode
ExitSuccess ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
code)
                }
      resDat :: McpToolsCallResponseData
resDat = JsonRpcRequest
-> McpToolsCallResponseResult -> McpToolsCallResponseData
DM.McpToolsCallResponseData JsonRpcRequest
jsonRpc McpToolsCallResponseResult
result
      res :: McpResponse
res = McpToolsCallResponseData -> McpResponse
DM.McpToolsCallResponse McpToolsCallResponseData
resDat

  STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue McpResponse -> McpResponse -> STM ()
forall a. TQueue a -> a -> STM ()
STM.writeTQueue TQueue McpResponse
resQ McpResponse
res

-- |
--
errorToolsCallResponse :: DM.JsonRpcRequest -> String -> AppContext ()
errorToolsCallResponse :: JsonRpcRequest -> [Char] -> AppContext ()
errorToolsCallResponse JsonRpcRequest
jsonRpc [Char]
errStr = do
  let content :: [McpToolsCallResponseResultContent]
content = [ [Char] -> [Char] -> McpToolsCallResponseResultContent
DM.McpToolsCallResponseResultContent [Char]
"text" [Char]
errStr ]
      result :: McpToolsCallResponseResult
result = DM.McpToolsCallResponseResult {
                  _contentMcpToolsCallResponseResult :: [McpToolsCallResponseResultContent]
DM._contentMcpToolsCallResponseResult = [McpToolsCallResponseResultContent]
content
                , _isErrorMcpToolsCallResponseResult :: Bool
DM._isErrorMcpToolsCallResponseResult = Bool
True
                }
      resDat :: McpToolsCallResponseData
resDat = JsonRpcRequest
-> McpToolsCallResponseResult -> McpToolsCallResponseData
DM.McpToolsCallResponseData JsonRpcRequest
jsonRpc McpToolsCallResponseResult
result
      res :: McpResponse
res = McpToolsCallResponseData -> McpResponse
DM.McpToolsCallResponse McpToolsCallResponseData
resDat

  TQueue McpResponse
resQ <- Getting (TQueue McpResponse) DomainData (TQueue McpResponse)
-> DomainData -> TQueue McpResponse
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (TQueue McpResponse) DomainData (TQueue McpResponse)
Lens' DomainData (TQueue McpResponse)
DM.responseQueueDomainData (DomainData -> TQueue McpResponse)
-> ReaderT
     AppData
     (ReaderT DomainData (ExceptT [Char] (LoggingT IO)))
     DomainData
-> ReaderT
     AppData
     (ReaderT DomainData (ExceptT [Char] (LoggingT IO)))
     (TQueue McpResponse)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT DomainData (ExceptT [Char] (LoggingT IO)) DomainData
-> ReaderT
     AppData
     (ReaderT DomainData (ExceptT [Char] (LoggingT IO)))
     DomainData
forall (m :: * -> *) a. Monad m => m a -> ReaderT AppData m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ReaderT DomainData (ExceptT [Char] (LoggingT IO)) DomainData
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO () -> AppContext ()
forall a. IO a -> AppContext a
liftIOE (IO () -> AppContext ()) -> IO () -> AppContext ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue McpResponse -> McpResponse -> STM ()
forall a. TQueue a -> a -> STM ()
STM.writeTQueue TQueue McpResponse
resQ McpResponse
res

-- |
--
runProc :: STM.TMVar (Maybe ProcData) -> String -> [String] -> [(String, String)] -> IO ()
runProc :: TMVar (Maybe ProcData)
-> [Char] -> [[Char]] -> [([Char], [Char])] -> IO ()
runProc TMVar (Maybe ProcData)
procVar [Char]
cmd [[Char]]
args [([Char], [Char])]
addEnv = do

  Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr [Char]
"[INFO] PMS.Infra.ProcSpawn.DS.Core.procRunTask.runProc start."

  (Handle
fromPtyHandle, Handle
toProcHandle) <- IO (Handle, Handle)
S.createPipe
  (Handle
fromProcHandle, Handle
toPtyHandle) <- IO (Handle, Handle)
S.createPipe

  [([Char], [Char])]
baseEnv <- IO [([Char], [Char])]
Env.getEnvironment
  let cwd :: Maybe a
cwd = Maybe a
forall a. Maybe a
Nothing
      runEnvs :: Maybe [([Char], [Char])]
runEnvs = [([Char], [Char])] -> Maybe [([Char], [Char])]
forall a. a -> Maybe a
Just ([([Char], [Char])] -> Maybe [([Char], [Char])])
-> [([Char], [Char])] -> Maybe [([Char], [Char])]
forall a b. (a -> b) -> a -> b
$ [([Char], [Char])]
baseEnv [([Char], [Char])] -> [([Char], [Char])] -> [([Char], [Char])]
forall a. [a] -> [a] -> [a]
++ [([Char], [Char])]
addEnv

  Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"[INFO] env = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Maybe [([Char], [Char])] -> [Char]
forall a. Show a => a -> [Char]
show Maybe [([Char], [Char])]
runEnvs
  Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"[INFO] cmd = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cmd
  Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"[INFO] args = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show [[Char]]
args

  ProcessHandle
pHdl <- [Char]
-> [[Char]]
-> Maybe [Char]
-> Maybe [([Char], [Char])]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ProcessHandle
S.runProcess [Char]
cmd [[Char]]
args Maybe [Char]
forall a. Maybe a
cwd Maybe [([Char], [Char])]
runEnvs (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
fromPtyHandle) (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
toPtyHandle) (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
toPtyHandle)
  let procData :: ProcData
procData = ProcData {
                  _wHdLProcData :: Handle
_wHdLProcData = Handle
toProcHandle
                , _rHdlProcData :: Handle
_rHdlProcData = Handle
fromProcHandle
                , _eHdlProcData :: Handle
_eHdlProcData = Handle
fromProcHandle
                , _pHdlProcData :: ProcessHandle
_pHdlProcData = ProcessHandle
pHdl
                }

  STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar (Maybe ProcData) -> Maybe ProcData -> STM ()
forall a. TMVar a -> a -> STM ()
STM.putTMVar TMVar (Maybe ProcData)
procVar (ProcData -> Maybe ProcData
forall a. a -> Maybe a
Just ProcData
procData)

  Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr [Char]
"[INFO] PMS.Infra.ProcSpawn.DS.Core.procRunTask.runProc end."



-- |
--   
readProc :: ProcData -> IO BS.ByteString
readProc :: ProcData -> IO ByteString
readProc ProcData
dat = do
   let hdl :: Handle
hdl = ProcData
datProcData -> Getting Handle ProcData Handle -> Handle
forall s a. s -> Getting a s a -> a
^.Getting Handle ProcData Handle
Lens' ProcData Handle
rHdlProcData
   Handle -> Int -> IO ByteString
BS.hGetSome Handle
hdl Int
1024
{-
  out <- BS.hGetNonBlocking (dat^.rHdlProcData) 1024
  err <- BS.hGetNonBlocking (dat^.eHdlProcData) 1024
  let combined = out <> err
  let text = TE.decodeUtf8With (\_ _ -> Just '?') combined
  hPutStrLn stderr $ "[DEBUG readProc] received: " ++ T.unpack text
  return combined
-}
{-
  S.hSetBuffering fromPtyHandle NoBuffering
  S.hSetBuffering toPtyHandle   NoBuffering
  S.hSetBuffering fromProcHandle NoBuffering
  S.hSetBuffering toProcHandle   NoBuffering
  S.hSetBuffering fromProcEHandle NoBuffering
  S.hSetBuffering toPtyEHandle   NoBuffering


  mp <- findExecutable "ssh"
  hPutStrLn stderr $ "[INFO] findExecutable = " ++ show mp

  let pathKey = "PATH"
      openSSH = "C:\\Windows\\System32\\OpenSSH"
      updatedEnv = case lookup pathKey baseEnv of
        Just oldPath -> (pathKey, openSSH ++ ";" ++ oldPath) : filter ((/= pathKey) . fst) baseEnv
        Nothing      -> (pathKey, openSSH) : baseEnv

  hPutStrLn stderr $ "[INFO] updatedEnv = " ++ show updatedEnv
-}

{-
  S.hSetBuffering fromPtyHandle NoBuffering
  S.hSetBuffering toPtyHandle   NoBuffering
  S.hSetBuffering fromProcHandle NoBuffering
  S.hSetBuffering toProcHandle   NoBuffering

  osEnc <- mkTextEncoding "UTF-8//TRANSLIT"
  S.hSetEncoding toPtyHandle osEnc
  S.hSetEncoding fromPtyHandle S.utf8
  S.hSetEncoding toProcHandle S.utf8
  S.hSetEncoding fromProcHandle osEnc
-}
{-
  osEnc <- mkTextEncoding "UTF-8//TRANSLIT"

  let runEnvs = Nothing
      bufMode = S.NoBuffering
  --let bufMode = S.BlockBuffering $ Just 1024

  S.hSetBuffering toPhoityneHandle bufMode
  S.hSetEncoding toPhoityneHandle osEnc
  S.hSetNewlineMode toPhoityneHandle $ S.NewlineMode S.CRLF S.LF
  --S.hSetBinaryMode toPhoityneHandle True

  S.hSetBuffering fromPhoityneHandle bufMode
  S.hSetEncoding fromPhoityneHandle  S.utf8
  S.hSetNewlineMode fromPhoityneHandle $ S.NewlineMode S.LF S.LF
  --S.hSetBinaryMode fromPhoityneHandle True

  S.hSetBuffering toGHCiHandle bufMode
  S.hSetEncoding toGHCiHandle S.utf8
  S.hSetNewlineMode toGHCiHandle $ S.NewlineMode S.LF S.LF
  --S.hSetBinaryMode toGHCiHandle True

  S.hSetBuffering fromGHCiHandle bufMode
  S.hSetEncoding fromGHCiHandle osEnc
  S.hSetNewlineMode fromGHCiHandle $ S.NewlineMode S.CRLF S.LF
  --S.hSetBinaryMode fromGHCiHandle True
-}
{-
envall :: [(String, String)]
envall =
  [ ("Path", "C:\\Windows\\system32;C:\\Windows;C:\\Windows\\System32\\Wbem;C:\\Windows\\System32\\WindowsPowerShell\\v1.0\\;C:\\Windows\\System32\\OpenSSH\\;C:\\Program Files\\dotnet\\;C:\\Program Files (x86)\\NVIDIA Corporation\\PhysX\\Common;C:\\Program Files\\NVIDIA Corporation\\NVIDIA app\\NvDLISR;C:\\Program Files\\Git\\cmd;C:\\Program Files\\TortoiseGit\\bin;C:\\Program Files (x86)\\Windows Kits\\10\\Windows Performance Toolkit\\;C:\\Users\\phoityne\\AppData\\Local\\Microsoft\\WindowsApps;C:\\Users\\phoityne\\AppData\\Local\\Programs\\Microsoft VS Code\\bin;C:\\ghcup\\bin;C:\\Users\\phoityne\\.dotnet\\tools;c:\\tools\\ghcup\\bin;C:\\Users\\phoityne\\AppData\\Local\\Programs\\Microsoft VS Code Insiders\\bin;c:\\tools\\cabal\\bin;;C:\\Users\\phoityne\\.lmstudio\\bin")
--  , ("PATHEXT", ".COM;.EXE;.BAT;.CMD;.VBS;.VBE;.JS;.JSE;.WSF;.WSH;.MSC")
--  , ("PROCESSOR_ARCHITECTURE", "AMD64")
--  , ("PROCESSOR_IDENTIFIER", "Intel64 Family 6 Model 183 Stepping 1, GenuineIntel")
--  , ("PROCESSOR_LEVEL", "6")
--  , ("PROCESSOR_REVISION", "b701")
  , ("ProgramData", "C:\\ProgramData")  -- required for ssh.
-------  , ("ProgramFiles", "C:\\Program Files")
-------    , ("ProgramFiles(x86)", "C:\\Program Files (x86)")
-------    , ("ProgramW6432", "C:\\Program Files")
--  , ("PROMPT", "$P$G")
-------      , ("PSModulePath", "C:\\Program Files\\WindowsPowerShell\\Modules;C:\\Windows\\system32\\WindowsPowerShell\\v1.0\\Modules")
--  , ("PUBLIC", "C:\\Users\\Public")
--  , ("SESSIONNAME", "Console")
------  , ("SystemDrive", "C:")
  , ("SystemRoot", "C:\\Windows")  -- required for ssh.
------  , ("TEMP", "C:\\Users\\phoityne\\AppData\\Local\\Temp")
------  , ("TMP", "C:\\Users\\phoityne\\AppData\\Local\\Temp")
------  , ("USERDOMAIN", "GameNote")
------  , ("USERDOMAIN_ROAMINGPROFILE", "GameNote")
------  , ("USERNAME", "phoityne")
------  , ("USERPROFILE", "C:\\Users\\phoityne")
------  , ("windir", "C:\\Windows")
--  , ("ZES_ENABLE_SYSMAN", "1")
  ]
  -}