Utility.hs

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

module PMS.Infra.Agent.Socket.DS.Utility where

import Control.Lens
import System.IO
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 Network.Socket
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Char8 as C8
import Data.Char (toUpper)

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

-- |
--
runApp :: DM.DomainData -> AppData -> TimedFastLogger -> AppContext a -> IO (Either DM.ErrorData a)
runApp domDat appDat logger ctx =
  DM.runFastLoggerT domDat logger
    $ runExceptT
    $ flip runReaderT domDat
    $ runReaderT ctx appDat

-- |
--
liftIOE :: IO a -> AppContext 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

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

  resQ <- view DM.responseQueueDomainData <$> lift ask
  liftIOE $ STM.atomically $ STM.writeTQueue resQ res

---------------------------------------------------------------------------------
-- | Decode an uppercase/lowercase hex string to a ByteString.
-- Input is uppercased before decoding to tolerate mixed case (e.g. "000a1BFF").
-- Returns Left with an error message if the input is not valid hex.
hexToBytes :: String -> Either String BS.ByteString
hexToBytes hex =
  case B16.decode (C8.pack (map toUpper hex)) of
    Right bs  -> Right bs
    Left  err -> Left $ "hexToBytes: invalid hex string: " ++ err

-- | Convert a TCP host/port to a Handle.
-- The socket must not be used directly after socketToHandle.
createSocketHandle :: HostName -> ServiceName -> IO Handle
createSocketHandle host port = do
  sock <- createSocket host port
  hdl  <- socketToHandle sock ReadWriteMode
  hSetBuffering hdl NoBuffering
  return hdl

-- | Connect to a Unix Domain Socket path and return a Handle.
-- The socket must not be used directly after socketToHandle.
-- Supported on Windows 10 Build 17063+ and Windows 11 via AF_UNIX (network >= 3.1.3.0).
createUnixSocketHandle :: FilePath -> IO Handle
createUnixSocketHandle path = do
  sock <- socket AF_UNIX Stream defaultProtocol
  connect sock (SockAddrUnix path)
  hdl  <- socketToHandle sock ReadWriteMode
  hSetBuffering hdl NoBuffering
  return hdl

-- |
--
createSocket :: HostName -> ServiceName -> IO Socket
createSocket host port = do
  let hint  = Just defaultHints { addrSocketType = Stream }
      justH = Just host
      justP = Just port

  getAddrInfo hint justH justP >>= \case
    [] -> E.throwString "No suitable address found for the given host and port."
    (serverAddr:_) -> do
      sock <- socket (addrFamily serverAddr) (addrSocketType serverAddr) (addrProtocol serverAddr)
      connect sock (addrAddress serverAddr)
      return sock