1{-# LANGUAGE OverloadedStrings #-} 2-- | 3-- Module : Network.TLS.Context.Internal 4-- License : BSD-style 5-- Maintainer : Vincent Hanquez <vincent@snarc.org> 6-- Stability : experimental 7-- Portability : unknown 8-- 9module Network.TLS.Context.Internal 10 ( 11 -- * Context configuration 12 ClientParams(..) 13 , ServerParams(..) 14 , defaultParamsClient 15 , SessionID 16 , SessionData(..) 17 , MaxFragmentEnum(..) 18 , Measurement(..) 19 20 -- * Context object and accessor 21 , Context(..) 22 , Hooks(..) 23 , Established(..) 24 , PendingAction(..) 25 , ctxEOF 26 , ctxHasSSLv2ClientHello 27 , ctxDisableSSLv2ClientHello 28 , ctxEstablished 29 , withLog 30 , ctxWithHooks 31 , contextModifyHooks 32 , setEOF 33 , setEstablished 34 , contextFlush 35 , contextClose 36 , contextSend 37 , contextRecv 38 , updateMeasure 39 , withMeasure 40 , withReadLock 41 , withWriteLock 42 , withStateLock 43 , withRWLock 44 45 -- * information 46 , Information(..) 47 , contextGetInformation 48 49 -- * Using context states 50 , throwCore 51 , failOnEitherError 52 , usingState 53 , usingState_ 54 , runTxState 55 , runRxState 56 , usingHState 57 , getHState 58 , saveHState 59 , restoreHState 60 , getStateRNG 61 , tls13orLater 62 , addCertRequest13 63 , getCertRequest13 64 , decideRecordVersion 65 ) where 66 67import Network.TLS.Backend 68import Network.TLS.Extension 69import Network.TLS.Cipher 70import Network.TLS.Struct 71import Network.TLS.Struct13 72import Network.TLS.Compression (Compression) 73import Network.TLS.State 74import Network.TLS.Handshake.State 75import Network.TLS.Hooks 76import Network.TLS.Record.State 77import Network.TLS.Parameters 78import Network.TLS.Measurement 79import Network.TLS.Imports 80import Network.TLS.Types 81import Network.TLS.Util 82import qualified Data.ByteString as B 83 84import Control.Concurrent.MVar 85import Control.Monad.State.Strict 86import Control.Exception (throwIO, Exception()) 87import Data.IORef 88import Data.Tuple 89 90 91-- | Information related to a running context, e.g. current cipher 92data Information = Information 93 { infoVersion :: Version 94 , infoCipher :: Cipher 95 , infoCompression :: Compression 96 , infoMasterSecret :: Maybe ByteString 97 , infoExtendedMasterSec :: Bool 98 , infoClientRandom :: Maybe ClientRandom 99 , infoServerRandom :: Maybe ServerRandom 100 , infoNegotiatedGroup :: Maybe Group 101 , infoTLS13HandshakeMode :: Maybe HandshakeMode13 102 , infoIsEarlyDataAccepted :: Bool 103 } deriving (Show,Eq) 104 105-- | A TLS Context keep tls specific state, parameters and backend information. 106data Context = Context 107 { ctxConnection :: Backend -- ^ return the backend object associated with this context 108 , ctxSupported :: Supported 109 , ctxShared :: Shared 110 , ctxState :: MVar TLSState 111 , ctxMeasurement :: IORef Measurement 112 , ctxEOF_ :: IORef Bool -- ^ has the handle EOFed or not. 113 , ctxEstablished_ :: IORef Established -- ^ has the handshake been done and been successful. 114 , ctxNeedEmptyPacket :: IORef Bool -- ^ empty packet workaround for CBC guessability. 115 , ctxSSLv2ClientHello :: IORef Bool -- ^ enable the reception of compatibility SSLv2 client hello. 116 -- the flag will be set to false regardless of its initial value 117 -- after the first packet received. 118 , ctxTxState :: MVar RecordState -- ^ current tx state 119 , ctxRxState :: MVar RecordState -- ^ current rx state 120 , ctxHandshake :: MVar (Maybe HandshakeState) -- ^ optional handshake state 121 , ctxDoHandshake :: Context -> IO () 122 , ctxDoHandshakeWith :: Context -> Handshake -> IO () 123 , ctxDoRequestCertificate :: Context -> IO Bool 124 , ctxDoPostHandshakeAuthWith :: Context -> Handshake13 -> IO () 125 , ctxHooks :: IORef Hooks -- ^ hooks for this context 126 , ctxLockWrite :: MVar () -- ^ lock to use for writing data (including updating the state) 127 , ctxLockRead :: MVar () -- ^ lock to use for reading data (including updating the state) 128 , ctxLockState :: MVar () -- ^ lock used during read/write when receiving and sending packet. 129 -- it is usually nested in a write or read lock. 130 , ctxPendingActions :: IORef [PendingAction] 131 , ctxCertRequests :: IORef [Handshake13] -- ^ pending PHA requests 132 , ctxKeyLogger :: String -> IO () 133 } 134 135data Established = NotEstablished 136 | EarlyDataAllowed Int -- remaining 0-RTT bytes allowed 137 | EarlyDataNotAllowed Int -- remaining 0-RTT packets allowed to skip 138 | Established 139 deriving (Eq, Show) 140 141data PendingAction 142 = PendingAction Bool (Handshake13 -> IO ()) 143 -- ^ simple pending action 144 | PendingActionHash Bool (ByteString -> Handshake13 -> IO ()) 145 -- ^ pending action taking transcript hash up to preceding message 146 147updateMeasure :: Context -> (Measurement -> Measurement) -> IO () 148updateMeasure ctx f = do 149 x <- readIORef (ctxMeasurement ctx) 150 writeIORef (ctxMeasurement ctx) $! f x 151 152withMeasure :: Context -> (Measurement -> IO a) -> IO a 153withMeasure ctx f = readIORef (ctxMeasurement ctx) >>= f 154 155-- | A shortcut for 'backendFlush . ctxConnection'. 156contextFlush :: Context -> IO () 157contextFlush = backendFlush . ctxConnection 158 159-- | A shortcut for 'backendClose . ctxConnection'. 160contextClose :: Context -> IO () 161contextClose = backendClose . ctxConnection 162 163-- | Information about the current context 164contextGetInformation :: Context -> IO (Maybe Information) 165contextGetInformation ctx = do 166 ver <- usingState_ ctx $ gets stVersion 167 hstate <- getHState ctx 168 let (ms, ems, cr, sr, hm13, grp) = 169 case hstate of 170 Just st -> (hstMasterSecret st, 171 hstExtendedMasterSec st, 172 Just (hstClientRandom st), 173 hstServerRandom st, 174 if ver == Just TLS13 then Just (hstTLS13HandshakeMode st) else Nothing, 175 hstNegotiatedGroup st) 176 Nothing -> (Nothing, False, Nothing, Nothing, Nothing, Nothing) 177 (cipher,comp) <- failOnEitherError $ runRxState ctx $ gets $ \st -> (stCipher st, stCompression st) 178 let accepted = case hstate of 179 Just st -> hstTLS13RTT0Status st == RTT0Accepted 180 Nothing -> False 181 case (ver, cipher) of 182 (Just v, Just c) -> return $ Just $ Information v c comp ms ems cr sr grp hm13 accepted 183 _ -> return Nothing 184 185contextSend :: Context -> ByteString -> IO () 186contextSend c b = updateMeasure c (addBytesSent $ B.length b) >> (backendSend $ ctxConnection c) b 187 188contextRecv :: Context -> Int -> IO ByteString 189contextRecv c sz = updateMeasure c (addBytesReceived sz) >> (backendRecv $ ctxConnection c) sz 190 191ctxEOF :: Context -> IO Bool 192ctxEOF ctx = readIORef $ ctxEOF_ ctx 193 194ctxHasSSLv2ClientHello :: Context -> IO Bool 195ctxHasSSLv2ClientHello ctx = readIORef $ ctxSSLv2ClientHello ctx 196 197ctxDisableSSLv2ClientHello :: Context -> IO () 198ctxDisableSSLv2ClientHello ctx = writeIORef (ctxSSLv2ClientHello ctx) False 199 200setEOF :: Context -> IO () 201setEOF ctx = writeIORef (ctxEOF_ ctx) True 202 203ctxEstablished :: Context -> IO Established 204ctxEstablished ctx = readIORef $ ctxEstablished_ ctx 205 206ctxWithHooks :: Context -> (Hooks -> IO a) -> IO a 207ctxWithHooks ctx f = readIORef (ctxHooks ctx) >>= f 208 209contextModifyHooks :: Context -> (Hooks -> Hooks) -> IO () 210contextModifyHooks ctx = modifyIORef (ctxHooks ctx) 211 212setEstablished :: Context -> Established -> IO () 213setEstablished ctx = writeIORef (ctxEstablished_ ctx) 214 215withLog :: Context -> (Logging -> IO ()) -> IO () 216withLog ctx f = ctxWithHooks ctx (f . hookLogging) 217 218throwCore :: (MonadIO m, Exception e) => e -> m a 219throwCore = liftIO . throwIO 220 221failOnEitherError :: MonadIO m => m (Either TLSError a) -> m a 222failOnEitherError f = do 223 ret <- f 224 case ret of 225 Left err -> throwCore err 226 Right r -> return r 227 228usingState :: Context -> TLSSt a -> IO (Either TLSError a) 229usingState ctx f = 230 modifyMVar (ctxState ctx) $ \st -> 231 let (a, newst) = runTLSState f st 232 in newst `seq` return (newst, a) 233 234usingState_ :: Context -> TLSSt a -> IO a 235usingState_ ctx f = failOnEitherError $ usingState ctx f 236 237usingHState :: MonadIO m => Context -> HandshakeM a -> m a 238usingHState ctx f = liftIO $ modifyMVar (ctxHandshake ctx) $ \mst -> 239 case mst of 240 Nothing -> throwCore $ Error_Misc "missing handshake" 241 Just st -> return $ swap (Just <$> runHandshake st f) 242 243getHState :: MonadIO m => Context -> m (Maybe HandshakeState) 244getHState ctx = liftIO $ readMVar (ctxHandshake ctx) 245 246saveHState :: Context -> IO (Saved (Maybe HandshakeState)) 247saveHState ctx = saveMVar (ctxHandshake ctx) 248 249restoreHState :: Context 250 -> Saved (Maybe HandshakeState) 251 -> IO (Saved (Maybe HandshakeState)) 252restoreHState ctx = restoreMVar (ctxHandshake ctx) 253 254decideRecordVersion :: Context -> IO (Version, Bool) 255decideRecordVersion ctx = do 256 ver <- usingState_ ctx (getVersionWithDefault $ maximum $ supportedVersions $ ctxSupported ctx) 257 hrr <- usingState_ ctx getTLS13HRR 258 -- For TLS 1.3, ver' is only used in ClientHello. 259 -- The record version of the first ClientHello SHOULD be TLS 1.0. 260 -- The record version of the second ClientHello MUST be TLS 1.2. 261 let ver' 262 | ver >= TLS13 = if hrr then TLS12 else TLS10 263 | otherwise = ver 264 return (ver', ver >= TLS13) 265 266runTxState :: Context -> RecordM a -> IO (Either TLSError a) 267runTxState ctx f = do 268 (ver, tls13) <- decideRecordVersion ctx 269 let opt = RecordOptions { recordVersion = ver 270 , recordTLS13 = tls13 271 } 272 modifyMVar (ctxTxState ctx) $ \st -> 273 case runRecordM f opt st of 274 Left err -> return (st, Left err) 275 Right (a, newSt) -> return (newSt, Right a) 276 277runRxState :: Context -> RecordM a -> IO (Either TLSError a) 278runRxState ctx f = do 279 ver <- usingState_ ctx getVersion 280 -- For 1.3, ver is just ignored. So, it is not necessary to convert ver. 281 let opt = RecordOptions { recordVersion = ver 282 , recordTLS13 = ver >= TLS13 283 } 284 modifyMVar (ctxRxState ctx) $ \st -> 285 case runRecordM f opt st of 286 Left err -> return (st, Left err) 287 Right (a, newSt) -> return (newSt, Right a) 288 289getStateRNG :: Context -> Int -> IO ByteString 290getStateRNG ctx n = usingState_ ctx $ genRandom n 291 292withReadLock :: Context -> IO a -> IO a 293withReadLock ctx f = withMVar (ctxLockRead ctx) (const f) 294 295withWriteLock :: Context -> IO a -> IO a 296withWriteLock ctx f = withMVar (ctxLockWrite ctx) (const f) 297 298withRWLock :: Context -> IO a -> IO a 299withRWLock ctx f = withReadLock ctx $ withWriteLock ctx f 300 301withStateLock :: Context -> IO a -> IO a 302withStateLock ctx f = withMVar (ctxLockState ctx) (const f) 303 304tls13orLater :: MonadIO m => Context -> m Bool 305tls13orLater ctx = do 306 ev <- liftIO $ usingState ctx $ getVersionWithDefault TLS10 -- fixme 307 return $ case ev of 308 Left _ -> False 309 Right v -> v >= TLS13 310 311addCertRequest13 :: Context -> Handshake13 -> IO () 312addCertRequest13 ctx certReq = modifyIORef (ctxCertRequests ctx) (certReq:) 313 314getCertRequest13 :: Context -> CertReqContext -> IO (Maybe Handshake13) 315getCertRequest13 ctx context = do 316 let ref = ctxCertRequests ctx 317 l <- readIORef ref 318 let (matched, others) = partition (\(CertRequest13 c _) -> context == c) l 319 case matched of 320 [] -> return Nothing 321 (certReq:_) -> writeIORef ref others >> return (Just certReq) 322