move logging into dynamic hooks

core/Network/TLS.hs

@@ -14,6 +14,7 @@ module Network.TLS
     , ServerHooks(..)
     , Supported(..)
     , Shared(..)
+    , Hooks(..)
     , Logging(..)
     , Measurement(..)
     , CertificateUsage(..)

core/Network/TLS/Context.hs

@@ -17,7 +17,7 @@ module Network.TLS.Context
     , ctxHasSSLv2ClientHello
     , ctxDisableSSLv2ClientHello
     , ctxEstablished
-    , ctxLogging
+    , withLog
     , ctxWithHooks
     , modifyHooks
     , setEOF
@@ -46,6 +46,7 @@ module Network.TLS.Context
     -- * Context hooks
     , contextHookSetHandshakeRecv
     , contextHookSetCertificateRecv
+    , contextHookSetLogging
 
     -- * Using context states
     , throwCore
@@ -208,8 +209,12 @@ contextNewOnSocket sock params st = contextNew sock params st
 
 contextHookSetHandshakeRecv :: Context -> (Handshake -> IO Handshake) -> IO ()
 contextHookSetHandshakeRecv context f =
-    liftIO $ modifyIORef (ctxHooks context) (\hooks -> hooks { hookRecvHandshake = f })
+    modifyHooks context (\hooks -> hooks { hookRecvHandshake = f })
 
 contextHookSetCertificateRecv :: Context -> (CertificateChain -> IO ()) -> IO ()
 contextHookSetCertificateRecv context f =
-    liftIO $ modifyIORef (ctxHooks context) (\hooks -> hooks { hookRecvCertificates = f })
+    modifyHooks context (\hooks -> hooks { hookRecvCertificates = f })
+
+contextHookSetLogging :: Context -> Logging -> IO ()
+contextHookSetLogging context loggingCallbacks =
+    modifyHooks context (\hooks -> hooks { hookLogging = loggingCallbacks })

core/Network/TLS/Context/Internal.hs

@@ -23,7 +23,7 @@ module Network.TLS.Context.Internal
     , ctxHasSSLv2ClientHello
     , ctxDisableSSLv2ClientHello
     , ctxEstablished
-    , ctxLogging
+    , withLog
     , ctxWithHooks
     , modifyHooks
     , setEOF
@@ -161,8 +161,8 @@ modifyHooks ctx f = modifyIORef (ctxHooks ctx) f
 setEstablished :: Context -> Bool -> IO ()
 setEstablished ctx v = writeIORef (ctxEstablished_ ctx) v
 
-ctxLogging :: Context -> Logging
-ctxLogging = logging . ctxCommonHooks
+withLog :: Context -> (Logging -> IO ()) -> IO ()
+withLog ctx f = ctxWithHooks ctx (f . hookLogging)
 
 throwCore :: (MonadIO m, Exception e) => e -> m a
 throwCore = liftIO . throwIO

core/Network/TLS/Hooks.hs

@@ -17,6 +17,8 @@ import Network.TLS.X509 (CertificateChain)
 import Data.Default.Class
 
 -- | Hooks for logging
+--
+-- This is called when sending and receiving packets and IO
 data Logging = Logging
     { loggingPacketSent :: String -> IO ()
     , loggingPacketRecv :: String -> IO ()
@@ -42,12 +44,15 @@ data Hooks = Hooks
       hookRecvHandshake    :: Handshake -> IO Handshake
       -- | called at each certificate chain message received
     , hookRecvCertificates :: CertificateChain -> IO ()
+      -- | hooks on IO and packets, receiving and sending.
+    , hookLogging          :: Logging
     }
 
 defaultHooks :: Hooks
 defaultHooks = Hooks
     { hookRecvHandshake    = \hs -> return hs
     , hookRecvCertificates = return . const ()
+    , hookLogging          = def
     }
 
 instance Default Hooks where

core/Network/TLS/IO.hs

@@ -75,7 +75,7 @@ recvRecord compatSSLv2 ctx
               maximumSizeExceeded = Error_Protocol ("record exceeding maximum size", True, RecordOverflow)
               getRecord :: Header -> Bytes -> IO (Either TLSError (Record Plaintext))
               getRecord header content = do
-                    liftIO $ (loggingIORecv $ ctxLogging ctx) header content
+                    liftIO $ withLog ctx $ \logging -> loggingIORecv logging header content
                     runRxState ctx $ disengageRecord $ rawToRecord header (fragmentCiphertext content)
 
 
@@ -96,7 +96,7 @@ recvPacket ctx = liftIO $ do
                             (mapM (hookRecvHandshake hooks) hss) >>= return . Right . Handshake
                     _                     -> return pktRecv
             case pkt of
-                Right p -> (loggingPacketRecv $ ctxLogging ctx) $ show p
+                Right p -> withLog ctx $ \logging -> loggingPacketRecv logging $ show p
                 _       -> return ()
             when compatSSLv2 $ ctxDisableSSLv2ClientHello ctx
             return pkt
@@ -110,12 +110,13 @@ sendPacket ctx pkt = do
     withEmptyPacket <- liftIO $ readIORef $ ctxNeedEmptyPacket ctx
     when (isNonNullAppData pkt && withEmptyPacket) $ sendPacket ctx $ AppData B.empty
 
-    liftIO $ (loggingPacketSent $ ctxLogging ctx) (show pkt)
-    edataToSend <- liftIO (writePacket ctx pkt)
+    edataToSend <- liftIO $ do
+                        withLog ctx $ \logging -> loggingPacketSent logging (show pkt)
+                        writePacket ctx pkt
     case edataToSend of
         Left err         -> throwCore err
-        Right dataToSend -> do
-            liftIO $ (loggingIOSent $ ctxLogging ctx) dataToSend
-            liftIO $ contextSend ctx dataToSend
+        Right dataToSend -> liftIO $ do
+            withLog ctx $ \logging -> loggingIOSent logging dataToSend
+            contextSend ctx dataToSend
   where isNonNullAppData (AppData b) = not $ B.null b
         isNonNullAppData _           = False

core/Network/TLS/Parameters.hs

@@ -19,7 +19,6 @@ module Network.TLS.Parameters
     , defaultParamsClient
     -- * Parameters
     , MaxFragmentEnum(..)
-    , Logging(..)
     , CertificateUsage(..)
     , CertificateRejectReason(..)
     ) where
@@ -248,7 +247,6 @@ instance Default ServerHooks where
 
 data CommonHooks = CommonHooks
     { onHandshake        :: Measurement -> IO Bool -- ^ callback on a beggining of handshake
-    , logging            :: Logging                -- ^ callback for logging
     }
 
 instance Show CommonHooks where
@@ -256,6 +254,5 @@ instance Show CommonHooks where
 
 instance Default CommonHooks where
     def = CommonHooks
-        { logging            = def
-        , onHandshake        = \_ -> return True
+        { onHandshake        = \_ -> return True
         }