{-# LANGUAGE TypeFamilies #-}

module Metro.TP.Debug
  ( Debug
  , DebugMode (..)
  , debugConfig
  ) where

import           Data.ByteString       (ByteString)
import           Data.ByteString.Char8 (unpack)
import           Metro.Class           (Transport (..))
import           System.Log.Logger     (debugM)

hex :: ByteString -> String
hex :: ByteString -> String
hex = (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
Prelude.concatMap Char -> String
forall a. Enum a => a -> String
w (String -> String)
-> (ByteString -> String) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
unpack
  where w :: a -> String
w ch :: a
ch = let s :: String
s = "0123456789ABCDEF"
                   x :: Int
x = a -> Int
forall a. Enum a => a -> Int
fromEnum a
ch
               in [String
s String -> Int -> Char
forall a. [a] -> Int -> a
!! Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
x 16,String
s String -> Int -> Char
forall a. [a] -> Int -> a
!! Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod Int
x 16]

data Debug tp = Debug String (ByteString -> String) tp

data DebugMode = Raw
    | Hex

instance Transport tp => Transport (Debug tp) where
  data TransportConfig (Debug tp) = DebugConfig String DebugMode (TransportConfig tp)
  newTransport :: TransportConfig (Debug tp) -> IO (Debug tp)
newTransport (DebugConfig h mode config) = do
    tp
tp <- TransportConfig tp -> IO tp
forall transport.
Transport transport =>
TransportConfig transport -> IO transport
newTransport TransportConfig tp
config
    Debug tp -> IO (Debug tp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Debug tp -> IO (Debug tp)) -> Debug tp -> IO (Debug tp)
forall a b. (a -> b) -> a -> b
$ String -> (ByteString -> String) -> tp -> Debug tp
forall tp. String -> (ByteString -> String) -> tp -> Debug tp
Debug String
h ByteString -> String
f tp
tp
    where f :: ByteString -> String
f = case DebugMode
mode of
                Raw -> ByteString -> String
forall a. Show a => a -> String
show
                Hex -> ByteString -> String
hex

  recvData :: Debug tp -> Int -> IO ByteString
recvData (Debug h :: String
h f :: ByteString -> String
f tp :: tp
tp) nbytes :: Int
nbytes = do
    ByteString
bs <- tp -> Int -> IO ByteString
forall transport.
Transport transport =>
transport -> Int -> IO ByteString
recvData tp
tp Int
nbytes
    String -> String -> IO ()
debugM "Metro.Transport.Debug" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
h String -> String -> String
forall a. [a] -> [a] -> [a]
++ " recv " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
f ByteString
bs
    ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
  sendData :: Debug tp -> ByteString -> IO ()
sendData (Debug h :: String
h f :: ByteString -> String
f tp :: tp
tp) bs :: ByteString
bs = do
    String -> String -> IO ()
debugM "Metro.Transport.Debug" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
h String -> String -> String
forall a. [a] -> [a] -> [a]
++ " send " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
f ByteString
bs
    tp -> ByteString -> IO ()
forall transport.
Transport transport =>
transport -> ByteString -> IO ()
sendData tp
tp ByteString
bs
  closeTransport :: Debug tp -> IO ()
closeTransport (Debug h :: String
h _ tp :: tp
tp) = do
    String -> String -> IO ()
debugM "Metro.Transport.Debug" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
h String -> String -> String
forall a. [a] -> [a] -> [a]
++ " transport close"
    tp -> IO ()
forall transport. Transport transport => transport -> IO ()
closeTransport tp
tp

debugConfig :: String -> DebugMode -> TransportConfig tp -> TransportConfig (Debug tp)
debugConfig :: String
-> DebugMode -> TransportConfig tp -> TransportConfig (Debug tp)
debugConfig = String
-> DebugMode -> TransportConfig tp -> TransportConfig (Debug tp)
forall tp.
String
-> DebugMode -> TransportConfig tp -> TransportConfig (Debug tp)
DebugConfig