Core.hs

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

module PMS.Infra.Agent.Serial.DS.Core where

import System.IO
import System.Hardware.Serialport
import Control.Monad.Logger
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Lens
import Control.Monad.Reader
import Control.Concurrent.Async
import qualified Control.Concurrent.STM as STM
import Data.Conduit
import qualified Data.Text as T
import Control.Monad.Except
import qualified Control.Exception.Safe as E
import System.Exit
import Data.Aeson

import qualified Data.ByteString as BS
import qualified PMS.Domain.Model.DS.Utility as DM
import qualified PMS.Domain.Model.DM.Type as DM
import qualified PMS.Domain.Model.DM.Constant as DM

import PMS.Infra.Agent.Serial.DM.Type
import PMS.Infra.Agent.Serial.DM.Constant
import PMS.Infra.Agent.Serial.DS.Utility


-- |
--
app :: AppContext ()
app = do
  $logDebugS DM._LOGTAG "app called."
  runConduit pipeline
  where
    pipeline :: ConduitM () Void AppContext ()
    pipeline = src .| cmd2task .| sink

---------------------------------------------------------------------------------
-- |
--
src :: ConduitT () DM.AgentSerialCommand AppContext ()
src = lift go >>= yield >> src
  where
    go :: AppContext DM.AgentSerialCommand
    go = do
      queue <- view DM.agentSerialQueueDomainData <$> lift ask
      dat <- liftIO $ STM.atomically $ STM.readTQueue queue
      return dat

---------------------------------------------------------------------------------
-- |
--
cmd2task :: ConduitT DM.AgentSerialCommand (IOTask ()) AppContext ()
cmd2task = await >>= \case
  Just cmd -> flip catchError (errHdl cmd) $ do
    lift (go cmd) >>= yield >> cmd2task
  Nothing -> do
    $logWarnS DM._LOGTAG "cmd2task: await returns nothing. skip."
    cmd2task

  where
    errHdl :: DM.AgentSerialCommand -> String -> ConduitT DM.AgentSerialCommand (IOTask ()) AppContext ()
    errHdl serialCmd msg = do
      let jsonrpc = DM.getJsonRpcAgentSerialCommand serialCmd
      $logWarnS DM._LOGTAG $ T.pack $ "cmd2task: exception occurred. skip. " ++ msg
      lift $ errorToolsCallResponse jsonrpc $ "cmd2task: exception occurred. skip. " ++ msg
      cmd2task

    go :: DM.AgentSerialCommand -> AppContext (IOTask ())
    go (DM.AgentSerialEchoCommand      dat) = genEchoTask dat
    go (DM.AgentSerialOpenCommand      dat) = genSerialOpenTask dat
    go (DM.AgentSerialCloseCommand     dat) = genSerialCloseTask dat
    go (DM.AgentSerialReadCommand      dat) = genSerialReadTask dat
    go (DM.AgentSerialWriteCommand     dat) = genSerialWriteTask dat
    go (DM.AgentSerialReadByteCommand  dat) = genSerialReadByteTask dat
    go (DM.AgentSerialWriteByteCommand dat) = genSerialWriteByteTask dat

---------------------------------------------------------------------------------
-- |
--
sink :: ConduitT (IOTask ()) Void AppContext ()
sink = await >>= \case
  Just req -> flip catchError errHdl $ do
    lift (go req) >> sink
  Nothing -> do
    $logWarnS DM._LOGTAG "sink: await returns nothing. skip."
    sink

  where
    errHdl :: String -> ConduitT (IOTask ()) Void AppContext ()
    errHdl msg = do
      $logWarnS DM._LOGTAG $ T.pack $ "sink: exception occurred. skip. " ++ msg
      sink

    go :: (IO ()) -> AppContext ()
    go task = do
      $logDebugS DM._LOGTAG "sink: start async."
      _ <- liftIOE $ async task
      $logDebugS DM._LOGTAG "sink: end async."
      return ()


---------------------------------------------------------------------------------
-- |
--
notImplemented :: String -> DM.JsonRpcRequest -> AppContext (IOTask ())
notImplemented name jsonRpc = do
  resQ <- view DM.responseQueueDomainData <$> lift ask
  return $ DM.toolsCallResponse resQ jsonRpc (ExitFailure 1) "" (name ++ ": not implemented yet.")

---------------------------------------------------------------------------------
-- |
--
genEchoTask :: DM.AgentSerialEchoCommandData -> AppContext (IOTask ())
genEchoTask dat = do
  resQ <- view DM.responseQueueDomainData <$> lift ask
  let val = dat^.DM.valueAgentSerialEchoCommandData
  $logDebugS DM._LOGTAG $ T.pack $ "genEchoTask: echo : " ++ val
  return $ echoTask resQ dat val

-- |
--
echoTask :: STM.TQueue DM.McpResponse -> DM.AgentSerialEchoCommandData -> String -> IOTask ()
echoTask resQ cmdDat val = flip E.catchAny errHdl $ do
  hPutStrLn stderr $ "[INFO] PMS.Infra.Agent.Serial.DS.Core.echoTask run. " ++ val
  DM.toolsCallResponse resQ (cmdDat^.DM.jsonrpcAgentSerialEchoCommandData) ExitSuccess val ""
  hPutStrLn stderr "[INFO] PMS.Infra.Agent.Serial.DS.Core.echoTask end."
  where
    errHdl :: E.SomeException -> IO ()
    errHdl e = DM.toolsCallResponse resQ (cmdDat^.DM.jsonrpcAgentSerialEchoCommandData) (ExitFailure 1) "" (show e)

---------------------------------------------------------------------------------
-- |
--
genSerialOpenTask :: DM.AgentSerialOpenCommandData -> AppContext (IOTask ())
genSerialOpenTask cmdDat = do
  let argsBS = DM.unRawJsonByteString $ cmdDat^.DM.argumentsAgentSerialOpenCommandData
  resQ        <- view DM.responseQueueDomainData <$> lift ask
  serialPortTMVar <- view serialPortAppData <$> ask
  argsDat     <- liftEither $ eitherDecode argsBS
  settings    <- getSerialSetting argsDat
  let device = argsDat^.deviceSerialToolParams
  return $ serialOpenTask cmdDat resQ serialPortTMVar device settings

-- |
--
serialOpenTask :: DM.AgentSerialOpenCommandData
               -> STM.TQueue DM.McpResponse
               -> STM.TMVar (Maybe SerialPort)
               -> String
               -> SerialPortSettings
               -> IOTask ()
serialOpenTask cmdDat resQ serialPortTMVar device settings = flip E.catchAny errHdl $ do
  hPutStrLn stderr "[INFO] PMS.Infra.Agent.Serial.DS.Core.serialOpenTask start."
  STM.atomically (STM.takeTMVar serialPortTMVar) >>= \case
    Just sp -> do
      STM.atomically $ STM.putTMVar serialPortTMVar (Just sp)
      hPutStrLn stderr "[ERROR] serialOpenTask: serial is already connected."
      DM.toolsCallResponse resQ jsonRpc (ExitFailure 1) "" "serial is already connected."
    Nothing -> flip E.catchAny connErrHdl $ do
      sp <- openSerial device settings
      STM.atomically $ STM.putTMVar serialPortTMVar (Just sp)
      DM.toolsCallResponse resQ jsonRpc ExitSuccess ("serial connected to " ++ device) ""
  hPutStrLn stderr "[INFO] PMS.Infra.Agent.Serial.DS.Core.serialOpenTask end."
  where
    jsonRpc = cmdDat^.DM.jsonrpcAgentSerialOpenCommandData
    errHdl :: E.SomeException -> IO ()
    errHdl e = DM.toolsCallResponse resQ jsonRpc (ExitFailure 1) "" (show e)
    connErrHdl :: E.SomeException -> IO ()
    connErrHdl e = do
      STM.atomically $ STM.putTMVar serialPortTMVar Nothing
      DM.toolsCallResponse resQ jsonRpc (ExitFailure 1) "" (show e)

---------------------------------------------------------------------------------
-- |
--
genSerialCloseTask :: DM.AgentSerialCloseCommandData -> AppContext (IOTask ())
genSerialCloseTask dat = do
  $logDebugS DM._LOGTAG $ T.pack $ "genSerialCloseTask called. "
  serialPortTMVar <- view serialPortAppData <$> ask
  resQ <- view DM.responseQueueDomainData <$> lift ask
  return $ serialCloseTask dat resQ serialPortTMVar

-- |
--
serialCloseTask :: DM.AgentSerialCloseCommandData
                -> STM.TQueue DM.McpResponse
                -> STM.TMVar (Maybe SerialPort)
                -> IOTask ()
serialCloseTask cmdDat resQ serialPortTMVar = flip E.catchAny errHdl $ do
  hPutStrLn stderr "[INFO] PMS.Infra.Agent.Serial.DS.Core.serialCloseTask run."
  let jsonRpc = cmdDat^.DM.jsonrpcAgentSerialCloseCommandData

  STM.atomically (STM.swapTMVar serialPortTMVar Nothing) >>= \case
    Nothing -> do
      hPutStrLn stderr "[ERROR] PMS.Infra.Agent.Serial.DS.Core.serialCloseTask: serial is not connected."
      DM.toolsCallResponse resQ jsonRpc (ExitFailure 1) "" "serial is not connected."
    Just sp -> do
      closeSerial sp
      DM.toolsCallResponse resQ jsonRpc ExitSuccess "" "serial is closed."
      hPutStrLn stderr "[INFO] PMS.Infra.Agent.Serial.DS.Core.serialCloseTask closeSerial."

  hPutStrLn stderr "[INFO] PMS.Infra.Agent.Serial.DS.Core.serialCloseTask end."

  where
    errHdl :: E.SomeException -> IO ()
    errHdl e = DM.toolsCallResponse resQ (cmdDat^.DM.jsonrpcAgentSerialCloseCommandData) (ExitFailure 1) "" (show e)

---------------------------------------------------------------------------------
-- |
--
genSerialReadTask :: DM.AgentSerialReadCommandData -> AppContext (IOTask ())
genSerialReadTask cmdData = do
  let argsBS = DM.unRawJsonByteString $ cmdData^.DM.argumentsAgentSerialReadCommandData
  resQ        <- view DM.responseQueueDomainData <$> lift ask
  serialPortTMVar <- view serialPortAppData <$> ask
  argsDat     <- liftEither $ eitherDecode argsBS
  let size       = argsDat^.sizeSerialIntToolParams
      actualSize = min size _READ_BUFFER_SIZE
  return $ serialReadTask cmdData resQ serialPortTMVar actualSize

-- |
--
serialReadTask :: DM.AgentSerialReadCommandData
               -> STM.TQueue DM.McpResponse
               -> STM.TMVar (Maybe SerialPort)
               -> Int
               -> IOTask ()
serialReadTask cmdDat resQ serialPortTMVar size = flip E.catchAny errHdl $ do
  hPutStrLn stderr $ "[INFO] PMS.Infra.Agent.Serial.DS.Core.serialReadTask run. " ++ show size

  STM.atomically (STM.readTMVar serialPortTMVar) >>= \case
    Nothing -> do
      hPutStrLn stderr "[ERROR] PMS.Infra.Agent.Serial.DS.Core.serialReadTask: serial is not connected."
      DM.toolsCallResponse resQ jsonRpc (ExitFailure 1) "" "serial is not connected."
    Just sp -> do
      output <- recv sp size
      DM.toolsCallResponse resQ jsonRpc ExitSuccess (DM.bs2strUTF8 output) ""

  hPutStrLn stderr "[INFO] PMS.Infra.Agent.Serial.DS.Core.serialReadTask end."

  where
    jsonRpc = cmdDat^.DM.jsonrpcAgentSerialReadCommandData
    errHdl :: E.SomeException -> IO ()
    errHdl e = DM.toolsCallResponse resQ jsonRpc (ExitFailure 1) "" (show e)

---------------------------------------------------------------------------------
-- |
--
genSerialReadByteTask :: DM.AgentSerialReadByteCommandData -> AppContext (IOTask ())
genSerialReadByteTask cmdData = do
  let argsBS = DM.unRawJsonByteString $ cmdData^.DM.argumentsAgentSerialReadByteCommandData
  resQ        <- view DM.responseQueueDomainData <$> lift ask
  serialPortTMVar <- view serialPortAppData <$> ask
  argsDat     <- liftEither $ eitherDecode argsBS
  let size       = argsDat^.sizeSerialIntToolParams
      actualSize = min size _READ_BUFFER_SIZE
  return $ serialReadByteTask cmdData resQ serialPortTMVar actualSize

-- |
--
serialReadByteTask :: DM.AgentSerialReadByteCommandData
                   -> STM.TQueue DM.McpResponse
                   -> STM.TMVar (Maybe SerialPort)
                   -> Int
                   -> IOTask ()
serialReadByteTask cmdDat resQ serialPortTMVar size = flip E.catchAny errHdl $ do
  hPutStrLn stderr $ "[INFO] PMS.Infra.Agent.Serial.DS.Core.serialReadByteTask run. " ++ show size

  STM.atomically (STM.readTMVar serialPortTMVar) >>= \case
    Nothing -> do
      hPutStrLn stderr "[ERROR] PMS.Infra.Agent.Serial.DS.Core.serialReadByteTask: serial is not connected."
      DM.toolsCallResponse resQ jsonRpc (ExitFailure 1) "" "serial is not connected."
    Just sp -> do
      output <- recv sp size
      DM.toolsCallResponse resQ jsonRpc ExitSuccess (DM.bytesToHex output) ""

  hPutStrLn stderr "[INFO] PMS.Infra.Agent.Serial.DS.Core.serialReadByteTask end."

  where
    jsonRpc = cmdDat^.DM.jsonrpcAgentSerialReadByteCommandData
    errHdl :: E.SomeException -> IO ()
    errHdl e = DM.toolsCallResponse resQ jsonRpc (ExitFailure 1) "" (show e)



---------------------------------------------------------------------------------
-- | CR-07 / invalidPatterns check: agent-serial-write implementation.
-- The invalidPatterns check is performed here in the gen function (AppContext),
-- consistent with how genSocketWriteTask performs the same check.
genSerialWriteTask :: DM.AgentSerialWriteCommandData -> AppContext (IOTask ())
genSerialWriteTask cmdData = do
  let argsBS = DM.unRawJsonByteString $ cmdData^.DM.argumentsAgentSerialWriteCommandData
  resQ            <- view DM.responseQueueDomainData <$> lift ask
  serialPortTMVar <- view serialPortAppData <$> ask
  invalidPatterns <- view DM.invalidPatternsDomainData <$> lift ask
  argsDat         <- liftEither $ eitherDecode argsBS
  let str           = argsDat^.dataSerialWriteToolParams
      appendNewline = argsDat^.appendNewlineSerialWriteToolParams
  -- invalidPatterns check (pure check, consistent with eitherDecode validation)
  case DM.checkInvalidPatterns invalidPatterns str of
    Just pat -> throwError $
      "agent-serial-write: rejected. input matches invalidPatterns: " ++ show pat
    Nothing  -> return ()
  return $ serialWriteTask cmdData resQ serialPortTMVar str appendNewline

-- |
--
serialWriteTask :: DM.AgentSerialWriteCommandData
                -> STM.TQueue DM.McpResponse
                -> STM.TMVar (Maybe SerialPort)
                -> String
                -> Maybe Bool
                -> IOTask ()
serialWriteTask cmdDat resQ serialPortTMVar str appendNewline = flip E.catchAny errHdl $ do
  hPutStrLn stderr "[INFO] PMS.Infra.Agent.Serial.DS.Core.serialWriteTask run."

  STM.atomically (STM.readTMVar serialPortTMVar) >>= \case
    Nothing ->
      DM.toolsCallResponse resQ jsonRpc (ExitFailure 1) "" "serial is not connected."
    Just sp -> do
      -- Apply appendCRLF (auto-append newline) unless appendNewline is explicitly False.
      let payload = if appendNewline == Just False
                      then str
                      else DM.appendCRLF str
          bs = DM.str2bsUTF8 payload
      hPutStrLn stderr $ "PMS.Infra.Agent.Serial.DS.Core.serialWriteTask " ++ show bs
      _ <- send sp bs
      DM.toolsCallResponse resQ jsonRpc ExitSuccess "" ""

  hPutStrLn stderr "[INFO] PMS.Infra.Agent.Serial.DS.Core.serialWriteTask end."

  where
    jsonRpc = cmdDat^.DM.jsonrpcAgentSerialWriteCommandData
    errHdl e = DM.toolsCallResponse resQ jsonRpc (ExitFailure 1) "" (show e)


---------------------------------------------------------------------------------
-- |
--
genSerialWriteByteTask :: DM.AgentSerialWriteByteCommandData -> AppContext (IOTask ())
genSerialWriteByteTask cmdData = do
  let argsBS = DM.unRawJsonByteString $ cmdData^.DM.argumentsAgentSerialWriteByteCommandData
  resQ        <- view DM.responseQueueDomainData <$> lift ask
  serialPortTMVar <- view serialPortAppData <$> ask
  argsDat     <- liftEither $ eitherDecode argsBS
  let hex = argsDat^.dataSerialHexToolParams
  bs          <- liftEither $ hexToBytes hex
  return $ serialWriteByteTask cmdData resQ serialPortTMVar bs

-- |
--
serialWriteByteTask :: DM.AgentSerialWriteByteCommandData
                    -> STM.TQueue DM.McpResponse
                    -> STM.TMVar (Maybe SerialPort)
                    -> BS.ByteString
                    -> IOTask ()
serialWriteByteTask cmdDat resQ serialPortTMVar bs = flip E.catchAny errHdl $ do
  hPutStrLn stderr "[INFO] PMS.Infra.Agent.Serial.DS.Core.serialWriteByteTask run."

  STM.atomically (STM.readTMVar serialPortTMVar) >>= \case
    Nothing ->
      DM.toolsCallResponse resQ jsonRpc (ExitFailure 1) "" "serial is not connected."
    Just sp -> do
      hPutStrLn stderr $ "PMS.Infra.Agent.Serial.DS.Core.serialWriteByteTask " ++ show bs
      _ <- send sp bs
      DM.toolsCallResponse resQ jsonRpc ExitSuccess "" ""

  hPutStrLn stderr "[INFO] PMS.Infra.Agent.Serial.DS.Core.serialWriteByteTask end."

  where
    jsonRpc = cmdDat^.DM.jsonrpcAgentSerialWriteByteCommandData
    errHdl e = DM.toolsCallResponse resQ jsonRpc (ExitFailure 1) "" (show e)