move logging into dynamic hooks
This commit is contained in:
parent
8dccb7d7bd
commit
251a0b2193
6 changed files with 28 additions and 19 deletions
|
@ -14,6 +14,7 @@ module Network.TLS
|
||||||
, ServerHooks(..)
|
, ServerHooks(..)
|
||||||
, Supported(..)
|
, Supported(..)
|
||||||
, Shared(..)
|
, Shared(..)
|
||||||
|
, Hooks(..)
|
||||||
, Logging(..)
|
, Logging(..)
|
||||||
, Measurement(..)
|
, Measurement(..)
|
||||||
, CertificateUsage(..)
|
, CertificateUsage(..)
|
||||||
|
|
|
@ -17,7 +17,7 @@ module Network.TLS.Context
|
||||||
, ctxHasSSLv2ClientHello
|
, ctxHasSSLv2ClientHello
|
||||||
, ctxDisableSSLv2ClientHello
|
, ctxDisableSSLv2ClientHello
|
||||||
, ctxEstablished
|
, ctxEstablished
|
||||||
, ctxLogging
|
, withLog
|
||||||
, ctxWithHooks
|
, ctxWithHooks
|
||||||
, modifyHooks
|
, modifyHooks
|
||||||
, setEOF
|
, setEOF
|
||||||
|
@ -46,6 +46,7 @@ module Network.TLS.Context
|
||||||
-- * Context hooks
|
-- * Context hooks
|
||||||
, contextHookSetHandshakeRecv
|
, contextHookSetHandshakeRecv
|
||||||
, contextHookSetCertificateRecv
|
, contextHookSetCertificateRecv
|
||||||
|
, contextHookSetLogging
|
||||||
|
|
||||||
-- * Using context states
|
-- * Using context states
|
||||||
, throwCore
|
, throwCore
|
||||||
|
@ -208,8 +209,12 @@ contextNewOnSocket sock params st = contextNew sock params st
|
||||||
|
|
||||||
contextHookSetHandshakeRecv :: Context -> (Handshake -> IO Handshake) -> IO ()
|
contextHookSetHandshakeRecv :: Context -> (Handshake -> IO Handshake) -> IO ()
|
||||||
contextHookSetHandshakeRecv context f =
|
contextHookSetHandshakeRecv context f =
|
||||||
liftIO $ modifyIORef (ctxHooks context) (\hooks -> hooks { hookRecvHandshake = f })
|
modifyHooks context (\hooks -> hooks { hookRecvHandshake = f })
|
||||||
|
|
||||||
contextHookSetCertificateRecv :: Context -> (CertificateChain -> IO ()) -> IO ()
|
contextHookSetCertificateRecv :: Context -> (CertificateChain -> IO ()) -> IO ()
|
||||||
contextHookSetCertificateRecv context f =
|
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 })
|
||||||
|
|
|
@ -23,7 +23,7 @@ module Network.TLS.Context.Internal
|
||||||
, ctxHasSSLv2ClientHello
|
, ctxHasSSLv2ClientHello
|
||||||
, ctxDisableSSLv2ClientHello
|
, ctxDisableSSLv2ClientHello
|
||||||
, ctxEstablished
|
, ctxEstablished
|
||||||
, ctxLogging
|
, withLog
|
||||||
, ctxWithHooks
|
, ctxWithHooks
|
||||||
, modifyHooks
|
, modifyHooks
|
||||||
, setEOF
|
, setEOF
|
||||||
|
@ -161,8 +161,8 @@ modifyHooks ctx f = modifyIORef (ctxHooks ctx) f
|
||||||
setEstablished :: Context -> Bool -> IO ()
|
setEstablished :: Context -> Bool -> IO ()
|
||||||
setEstablished ctx v = writeIORef (ctxEstablished_ ctx) v
|
setEstablished ctx v = writeIORef (ctxEstablished_ ctx) v
|
||||||
|
|
||||||
ctxLogging :: Context -> Logging
|
withLog :: Context -> (Logging -> IO ()) -> IO ()
|
||||||
ctxLogging = logging . ctxCommonHooks
|
withLog ctx f = ctxWithHooks ctx (f . hookLogging)
|
||||||
|
|
||||||
throwCore :: (MonadIO m, Exception e) => e -> m a
|
throwCore :: (MonadIO m, Exception e) => e -> m a
|
||||||
throwCore = liftIO . throwIO
|
throwCore = liftIO . throwIO
|
||||||
|
|
|
@ -17,6 +17,8 @@ import Network.TLS.X509 (CertificateChain)
|
||||||
import Data.Default.Class
|
import Data.Default.Class
|
||||||
|
|
||||||
-- | Hooks for logging
|
-- | Hooks for logging
|
||||||
|
--
|
||||||
|
-- This is called when sending and receiving packets and IO
|
||||||
data Logging = Logging
|
data Logging = Logging
|
||||||
{ loggingPacketSent :: String -> IO ()
|
{ loggingPacketSent :: String -> IO ()
|
||||||
, loggingPacketRecv :: String -> IO ()
|
, loggingPacketRecv :: String -> IO ()
|
||||||
|
@ -42,12 +44,15 @@ data Hooks = Hooks
|
||||||
hookRecvHandshake :: Handshake -> IO Handshake
|
hookRecvHandshake :: Handshake -> IO Handshake
|
||||||
-- | called at each certificate chain message received
|
-- | called at each certificate chain message received
|
||||||
, hookRecvCertificates :: CertificateChain -> IO ()
|
, hookRecvCertificates :: CertificateChain -> IO ()
|
||||||
|
-- | hooks on IO and packets, receiving and sending.
|
||||||
|
, hookLogging :: Logging
|
||||||
}
|
}
|
||||||
|
|
||||||
defaultHooks :: Hooks
|
defaultHooks :: Hooks
|
||||||
defaultHooks = Hooks
|
defaultHooks = Hooks
|
||||||
{ hookRecvHandshake = \hs -> return hs
|
{ hookRecvHandshake = \hs -> return hs
|
||||||
, hookRecvCertificates = return . const ()
|
, hookRecvCertificates = return . const ()
|
||||||
|
, hookLogging = def
|
||||||
}
|
}
|
||||||
|
|
||||||
instance Default Hooks where
|
instance Default Hooks where
|
||||||
|
|
|
@ -75,7 +75,7 @@ recvRecord compatSSLv2 ctx
|
||||||
maximumSizeExceeded = Error_Protocol ("record exceeding maximum size", True, RecordOverflow)
|
maximumSizeExceeded = Error_Protocol ("record exceeding maximum size", True, RecordOverflow)
|
||||||
getRecord :: Header -> Bytes -> IO (Either TLSError (Record Plaintext))
|
getRecord :: Header -> Bytes -> IO (Either TLSError (Record Plaintext))
|
||||||
getRecord header content = do
|
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)
|
runRxState ctx $ disengageRecord $ rawToRecord header (fragmentCiphertext content)
|
||||||
|
|
||||||
|
|
||||||
|
@ -96,7 +96,7 @@ recvPacket ctx = liftIO $ do
|
||||||
(mapM (hookRecvHandshake hooks) hss) >>= return . Right . Handshake
|
(mapM (hookRecvHandshake hooks) hss) >>= return . Right . Handshake
|
||||||
_ -> return pktRecv
|
_ -> return pktRecv
|
||||||
case pkt of
|
case pkt of
|
||||||
Right p -> (loggingPacketRecv $ ctxLogging ctx) $ show p
|
Right p -> withLog ctx $ \logging -> loggingPacketRecv logging $ show p
|
||||||
_ -> return ()
|
_ -> return ()
|
||||||
when compatSSLv2 $ ctxDisableSSLv2ClientHello ctx
|
when compatSSLv2 $ ctxDisableSSLv2ClientHello ctx
|
||||||
return pkt
|
return pkt
|
||||||
|
@ -110,12 +110,13 @@ sendPacket ctx pkt = do
|
||||||
withEmptyPacket <- liftIO $ readIORef $ ctxNeedEmptyPacket ctx
|
withEmptyPacket <- liftIO $ readIORef $ ctxNeedEmptyPacket ctx
|
||||||
when (isNonNullAppData pkt && withEmptyPacket) $ sendPacket ctx $ AppData B.empty
|
when (isNonNullAppData pkt && withEmptyPacket) $ sendPacket ctx $ AppData B.empty
|
||||||
|
|
||||||
liftIO $ (loggingPacketSent $ ctxLogging ctx) (show pkt)
|
edataToSend <- liftIO $ do
|
||||||
edataToSend <- liftIO (writePacket ctx pkt)
|
withLog ctx $ \logging -> loggingPacketSent logging (show pkt)
|
||||||
|
writePacket ctx pkt
|
||||||
case edataToSend of
|
case edataToSend of
|
||||||
Left err -> throwCore err
|
Left err -> throwCore err
|
||||||
Right dataToSend -> do
|
Right dataToSend -> liftIO $ do
|
||||||
liftIO $ (loggingIOSent $ ctxLogging ctx) dataToSend
|
withLog ctx $ \logging -> loggingIOSent logging dataToSend
|
||||||
liftIO $ contextSend ctx dataToSend
|
contextSend ctx dataToSend
|
||||||
where isNonNullAppData (AppData b) = not $ B.null b
|
where isNonNullAppData (AppData b) = not $ B.null b
|
||||||
isNonNullAppData _ = False
|
isNonNullAppData _ = False
|
||||||
|
|
|
@ -19,7 +19,6 @@ module Network.TLS.Parameters
|
||||||
, defaultParamsClient
|
, defaultParamsClient
|
||||||
-- * Parameters
|
-- * Parameters
|
||||||
, MaxFragmentEnum(..)
|
, MaxFragmentEnum(..)
|
||||||
, Logging(..)
|
|
||||||
, CertificateUsage(..)
|
, CertificateUsage(..)
|
||||||
, CertificateRejectReason(..)
|
, CertificateRejectReason(..)
|
||||||
) where
|
) where
|
||||||
|
@ -248,7 +247,6 @@ instance Default ServerHooks where
|
||||||
|
|
||||||
data CommonHooks = CommonHooks
|
data CommonHooks = CommonHooks
|
||||||
{ onHandshake :: Measurement -> IO Bool -- ^ callback on a beggining of handshake
|
{ onHandshake :: Measurement -> IO Bool -- ^ callback on a beggining of handshake
|
||||||
, logging :: Logging -- ^ callback for logging
|
|
||||||
}
|
}
|
||||||
|
|
||||||
instance Show CommonHooks where
|
instance Show CommonHooks where
|
||||||
|
@ -256,6 +254,5 @@ instance Show CommonHooks where
|
||||||
|
|
||||||
instance Default CommonHooks where
|
instance Default CommonHooks where
|
||||||
def = CommonHooks
|
def = CommonHooks
|
||||||
{ logging = def
|
{ onHandshake = \_ -> return True
|
||||||
, onHandshake = \_ -> return True
|
|
||||||
}
|
}
|
||||||
|
|
Loading…
Reference in a new issue