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

module PMS.Infra.Socket.DS.Utility where

import Control.Lens
import System.Exit
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 B
import Network.Socket.ByteString
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Char8 as C8
import Control.Monad 

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

-- |
--
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

-- |
--   
bytesToHex :: B.ByteString -> String
bytesToHex :: ByteString -> [Char]
bytesToHex = ByteString -> [Char]
C8.unpack (ByteString -> [Char])
-> (ByteString -> ByteString) -> ByteString -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B16.encode


-- |
--   
readSizeSocket :: Socket -> Int -> IO B.ByteString
readSizeSocket :: Socket -> Int -> IO ByteString
readSizeSocket Socket
sock Int
size = do
  ByteString
msg <- Socket -> Int -> IO ByteString
recv Socket
sock Int
size
  if ByteString -> Bool
B.null ByteString
msg
    then [Char] -> IO ByteString
forall (m :: * -> *) a.
(MonadThrow m, HasCallStack) =>
[Char] -> m a
E.throwString [Char]
"Connection closed by remote host"
    else do
      let hexMsg :: [Char]
hexMsg = ByteString -> [Char]
bytesToHex ByteString
msg
      Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"[DEBUG]PMS.Infra.Socket.DS.Utility.readSocket Received " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (ByteString -> Int
B.length ByteString
msg) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" bytes: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
hexMsg
      ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
msg

-- |
--   
writeSocket :: Socket -> B.ByteString -> IO ()
writeSocket :: Socket -> ByteString -> IO ()
writeSocket Socket
sock ByteString
bs = do
  Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"PMS.Infra.Socket.DS.Utility.writeSocket " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
bs
  Socket -> ByteString -> IO ()
sendAll Socket
sock ByteString
bs
 
-- |
--   
createSocket :: HostName -> ServiceName -> IO Socket
createSocket :: [Char] -> [Char] -> IO Socket
createSocket [Char]
host [Char]
port = do
  let hint :: Maybe AddrInfo
hint  = AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
defaultHints { addrSocketType = Stream }
      justH :: Maybe [Char]
justH = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
host
      justP :: Maybe [Char]
justP = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
port
  
  Maybe AddrInfo -> Maybe [Char] -> Maybe [Char] -> IO [AddrInfo]
forall (t :: * -> *).
GetAddrInfo t =>
Maybe AddrInfo -> Maybe [Char] -> Maybe [Char] -> IO (t AddrInfo)
getAddrInfo Maybe AddrInfo
hint Maybe [Char]
justH Maybe [Char]
justP IO [AddrInfo] -> ([AddrInfo] -> IO Socket) -> IO Socket
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      [] -> [Char] -> IO Socket
forall (m :: * -> *) a.
(MonadThrow m, HasCallStack) =>
[Char] -> m a
E.throwString [Char]
"No suitable address found for the given host and port."
      (AddrInfo
serverAddr:[AddrInfo]
_) -> do
          Socket
sock <- Family -> SocketType -> ProtocolNumber -> IO Socket
socket (AddrInfo -> Family
addrFamily AddrInfo
serverAddr) (AddrInfo -> SocketType
addrSocketType AddrInfo
serverAddr) (AddrInfo -> ProtocolNumber
addrProtocol AddrInfo
serverAddr)
          Socket -> SockAddr -> IO ()
connect Socket
sock (AddrInfo -> SockAddr
addrAddress AddrInfo
serverAddr)
          Socket -> IO Socket
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock
{-

-- |
--   
sendInitialTelnetOptions :: Socket -> IO ()
sendInitialTelnetOptions sock = do
    sendAll sock (iac <> wont <> telopt_echo)
    sendAll sock (iac <> wont <> telopt_suppress_ga)
    sendAll sock (iac <> wont <> telopt_naws)
    sendAll sock (iac <> wont <> telopt_ttype)
    sendAll sock (iac <> wont <> telopt_new_environ)

    sendAll sock (iac <> dont <> telopt_echo)
    sendAll sock (iac <> dont <> telopt_suppress_ga)
    sendAll sock (iac <> dont <> telopt_naws)
    sendAll sock (iac <> dont <> telopt_ttype)


-- |
--   
iac  = B.singleton 0xFF
do_  = B.singleton 0xFD
will = B.singleton 0xFB
wont = B.singleton 0xFC
dont = B.singleton 0xFE
-}

-- |
--   
respondToIAC :: Socket -> B.ByteString -> IO ()
respondToIAC :: Socket -> ByteString -> IO ()
respondToIAC Socket
sock ByteString
bs = ByteString -> IO ()
go ByteString
bs
  where
    go :: ByteString -> IO ()
go ByteString
s
      | ByteString -> Int
B.length ByteString
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
3 = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | HasCallStack => ByteString -> Word8
ByteString -> Word8
B.head ByteString
s Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0xFF =
          let cmd :: Word8
cmd  = HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
B.index ByteString
s Int
1
              opt :: Word8
opt  = HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
B.index ByteString
s Int
2
              rest :: ByteString
rest = Int -> ByteString -> ByteString
B.drop Int
3 ByteString
s
              rsp :: ByteString
rsp  = case Word8
cmd of
                       Word8
0xFD -> ByteString
iac ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
wont ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word8 -> ByteString
B.singleton Word8
opt
                       Word8
0xFB -> ByteString
iac ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
dont ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word8 -> ByteString
B.singleton Word8
opt
                       Word8
_    -> ByteString
B.empty
          in do
            let hexRsp :: [Char]
hexRsp = ByteString -> [Char]
bytesToHex ByteString
rsp
            Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"[DEBUG]PMS.Infra.Socket.DS.Utility.respondToIAC Sending response: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
hexRsp
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
B.null ByteString
rsp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Socket -> ByteString -> IO ()
sendAll Socket
sock ByteString
rsp
            ByteString -> IO ()
go ByteString
rest
      | Bool
otherwise = ByteString -> IO ()
go (HasCallStack => ByteString -> ByteString
ByteString -> ByteString
B.tail ByteString
s)


-- |
--   
readTelnetSocket :: Socket -> IO B.ByteString
readTelnetSocket :: Socket -> IO ByteString
readTelnetSocket Socket
sock = do
  ByteString
msg <- Socket -> Int -> IO ByteString
recv Socket
sock Int
4096
  if ByteString -> Bool
B.null ByteString
msg
    then [Char] -> IO ByteString
forall (m :: * -> *) a.
(MonadThrow m, HasCallStack) =>
[Char] -> m a
E.throwString [Char]
"Connection closed by remote host"
    else do
      let hexMsg :: [Char]
hexMsg = ByteString -> [Char]
bytesToHex ByteString
msg
      Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"[DEBUG]PMS.Infra.Socket.DS.Utility.readTelnetSocket Received " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (ByteString -> Int
B.length ByteString
msg) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" bytes: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
hexMsg

      if Word8
0xFF Word8 -> ByteString -> Bool
`B.elem` ByteString
msg
        then do
          Socket -> ByteString -> IO ()
respondToIAC Socket
sock ByteString
msg
          Socket -> IO ByteString
readTelnetSocket Socket
sock
        else
          ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
msg