1{-# OPTIONS_HADDOCK hide #-} 2{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, BangPatterns #-} 3-- | 4-- Module : Network.TLS.Core 5-- License : BSD-style 6-- Maintainer : Vincent Hanquez <vincent@snarc.org> 7-- Stability : experimental 8-- Portability : unknown 9-- 10module Network.TLS.Core 11 ( 12 -- * Internal packet sending and receiving 13 sendPacket 14 , recvPacket 15 16 -- * Initialisation and Termination of context 17 , bye 18 , handshake 19 20 -- * Application Layer Protocol Negotiation 21 , getNegotiatedProtocol 22 23 -- * Server Name Indication 24 , getClientSNI 25 26 -- * High level API 27 , sendData 28 , recvData 29 , recvData' 30 , updateKey 31 , KeyUpdateRequest(..) 32 , requestCertificate 33 ) where 34 35import Network.TLS.Cipher 36import Network.TLS.Context 37import Network.TLS.Crypto 38import Network.TLS.Struct 39import Network.TLS.Struct13 40import Network.TLS.State (getSession) 41import Network.TLS.Parameters 42import Network.TLS.IO 43import Network.TLS.Session 44import Network.TLS.Handshake 45import Network.TLS.Handshake.Common 46import Network.TLS.Handshake.Common13 47import Network.TLS.Handshake.Process 48import Network.TLS.Handshake.State 49import Network.TLS.Handshake.State13 50import Network.TLS.PostHandshake 51import Network.TLS.KeySchedule 52import Network.TLS.Types (Role(..), HostName, AnyTrafficSecret(..), ApplicationSecret) 53import Network.TLS.Util (catchException, mapChunks_) 54import Network.TLS.Extension 55import qualified Network.TLS.State as S 56import qualified Data.ByteString as B 57import qualified Data.ByteString.Char8 as C8 58import qualified Data.ByteString.Lazy as L 59import qualified Control.Exception as E 60 61import Control.Monad.State.Strict 62 63-- | notify the context that this side wants to close connection. 64-- this is important that it is called before closing the handle, otherwise 65-- the session might not be resumable (for version < TLS1.2). 66-- 67-- this doesn't actually close the handle 68bye :: MonadIO m => Context -> m () 69bye ctx = liftIO $ do 70 -- Although setEOF is always protected by the read lock, here we don't try 71 -- to wrap ctxEOF with it, so that function bye can still be called 72 -- concurrently to a blocked recvData. 73 eof <- ctxEOF ctx 74 tls13 <- tls13orLater ctx 75 unless eof $ withWriteLock ctx $ 76 if tls13 then 77 sendPacket13 ctx $ Alert13 [(AlertLevel_Warning, CloseNotify)] 78 else 79 sendPacket ctx $ Alert [(AlertLevel_Warning, CloseNotify)] 80 81-- | If the ALPN extensions have been used, this will 82-- return get the protocol agreed upon. 83getNegotiatedProtocol :: MonadIO m => Context -> m (Maybe B.ByteString) 84getNegotiatedProtocol ctx = liftIO $ usingState_ ctx S.getNegotiatedProtocol 85 86-- | If the Server Name Indication extension has been used, return the 87-- hostname specified by the client. 88getClientSNI :: MonadIO m => Context -> m (Maybe HostName) 89getClientSNI ctx = liftIO $ usingState_ ctx S.getClientSNI 90 91-- | sendData sends a bunch of data. 92-- It will automatically chunk data to acceptable packet size 93sendData :: MonadIO m => Context -> L.ByteString -> m () 94sendData ctx dataToSend = liftIO $ do 95 tls13 <- tls13orLater ctx 96 let sendP 97 | tls13 = sendPacket13 ctx . AppData13 98 | otherwise = sendPacket ctx . AppData 99 withWriteLock ctx $ do 100 checkValid ctx 101 -- All chunks are protected with the same write lock because we don't 102 -- want to interleave writes from other threads in the middle of our 103 -- possibly large write. 104 let len = ctxFragmentSize ctx 105 mapM_ (mapChunks_ len sendP) (L.toChunks dataToSend) 106 107-- | Get data out of Data packet, and automatically renegotiate if a Handshake 108-- ClientHello is received. An empty result means EOF. 109recvData :: MonadIO m => Context -> m B.ByteString 110recvData ctx = liftIO $ do 111 tls13 <- tls13orLater ctx 112 withReadLock ctx $ do 113 checkValid ctx 114 -- We protect with a read lock both reception and processing of the 115 -- packet, because don't want another thread to receive a new packet 116 -- before this one has been fully processed. 117 -- 118 -- Even when recvData1/recvData13 loops, we only need to call function 119 -- checkValid once. Since we hold the read lock, no concurrent call 120 -- will impact the validity of the context. 121 if tls13 then recvData13 ctx else recvData1 ctx 122 123recvData1 :: Context -> IO B.ByteString 124recvData1 ctx = do 125 pkt <- recvPacket ctx 126 either (onError terminate) process pkt 127 where process (Handshake [ch@ClientHello{}]) = 128 handshakeWith ctx ch >> recvData1 ctx 129 process (Handshake [hr@HelloRequest]) = 130 handshakeWith ctx hr >> recvData1 ctx 131 132 process (Alert [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx >> return B.empty 133 process (Alert [(AlertLevel_Fatal, desc)]) = do 134 setEOF ctx 135 E.throwIO (Terminated True ("received fatal error: " ++ show desc) (Error_Protocol ("remote side fatal error", True, desc))) 136 137 -- when receiving empty appdata, we just retry to get some data. 138 process (AppData "") = recvData1 ctx 139 process (AppData x) = return x 140 process p = let reason = "unexpected message " ++ show p in 141 terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason 142 143 terminate = terminateWithWriteLock ctx (sendPacket ctx . Alert) 144 145recvData13 :: Context -> IO B.ByteString 146recvData13 ctx = do 147 pkt <- recvPacket13 ctx 148 either (onError terminate) process pkt 149 where process (Alert13 [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx >> return B.empty 150 process (Alert13 [(AlertLevel_Fatal, desc)]) = do 151 setEOF ctx 152 E.throwIO (Terminated True ("received fatal error: " ++ show desc) (Error_Protocol ("remote side fatal error", True, desc))) 153 process (Handshake13 hs) = do 154 loopHandshake13 hs 155 recvData13 ctx 156 -- when receiving empty appdata, we just retry to get some data. 157 process (AppData13 "") = recvData13 ctx 158 process (AppData13 x) = do 159 let chunkLen = C8.length x 160 established <- ctxEstablished ctx 161 case established of 162 EarlyDataAllowed maxSize 163 | chunkLen <= maxSize -> do 164 setEstablished ctx $ EarlyDataAllowed (maxSize - chunkLen) 165 return x 166 | otherwise -> 167 let reason = "early data overflow" in 168 terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason 169 EarlyDataNotAllowed n 170 | n > 0 -> do 171 setEstablished ctx $ EarlyDataNotAllowed (n - 1) 172 recvData13 ctx -- ignore "x" 173 | otherwise -> 174 let reason = "early data deprotect overflow" in 175 terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason 176 Established -> return x 177 NotEstablished -> throwCore $ Error_Protocol ("data at not-established", True, UnexpectedMessage) 178 process ChangeCipherSpec13 = recvData13 ctx 179 process p = let reason = "unexpected message " ++ show p in 180 terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason 181 182 loopHandshake13 [] = return () 183 loopHandshake13 (ClientHello13{}:_) = do 184 let reason = "Client hello is not allowed" 185 terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason 186 -- fixme: some implementations send multiple NST at the same time. 187 -- Only the first one is used at this moment. 188 loopHandshake13 (NewSessionTicket13 life add nonce label exts:hs) = do 189 role <- usingState_ ctx S.isClientContext 190 unless (role == ClientRole) $ 191 let reason = "Session ticket is allowed for client only" 192 in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason 193 -- This part is similar to handshake code, so protected with 194 -- read+write locks (which is also what we use for all calls to the 195 -- session manager). 196 withWriteLock ctx $ do 197 Just resumptionMasterSecret <- usingHState ctx getTLS13ResumptionSecret 198 (_, usedCipher, _, _) <- getTxState ctx 199 let choice = makeCipherChoice TLS13 usedCipher 200 psk = derivePSK choice resumptionMasterSecret nonce 201 maxSize = case extensionLookup extensionID_EarlyData exts >>= extensionDecode MsgTNewSessionTicket of 202 Just (EarlyDataIndication (Just ms)) -> fromIntegral $ safeNonNegative32 ms 203 _ -> 0 204 life7d = min life 604800 -- 7 days max 205 tinfo <- createTLS13TicketInfo life7d (Right add) Nothing 206 sdata <- getSessionData13 ctx usedCipher tinfo maxSize psk 207 let !label' = B.copy label 208 sessionEstablish (sharedSessionManager $ ctxShared ctx) label' sdata 209 -- putStrLn $ "NewSessionTicket received: lifetime = " ++ show life ++ " sec" 210 loopHandshake13 hs 211 loopHandshake13 (KeyUpdate13 mode:hs) = do 212 when (ctxQUICMode ctx) $ do 213 let reason = "KeyUpdate is not allowed for QUIC" 214 terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason 215 checkAlignment hs 216 established <- ctxEstablished ctx 217 -- Though RFC 8446 Sec 4.6.3 does not clearly says, 218 -- unidirectional key update is legal. 219 -- So, we don't have to check if this key update is corresponding 220 -- to key update (update_requested) which we sent. 221 if established == Established then do 222 keyUpdate ctx getRxState setRxState 223 -- Write lock wraps both actions because we don't want another 224 -- packet to be sent by another thread before the Tx state is 225 -- updated. 226 when (mode == UpdateRequested) $ withWriteLock ctx $ do 227 sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested] 228 keyUpdate ctx getTxState setTxState 229 loopHandshake13 hs 230 else do 231 let reason = "received key update before established" 232 terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason 233 loopHandshake13 (h@CertRequest13{}:hs) = 234 postHandshakeAuthWith ctx h >> loopHandshake13 hs 235 loopHandshake13 (h@Certificate13{}:hs) = 236 postHandshakeAuthWith ctx h >> loopHandshake13 hs 237 loopHandshake13 (h:hs) = do 238 mPendingAction <- popPendingAction ctx 239 case mPendingAction of 240 Nothing -> let reason = "unexpected handshake message " ++ show h in 241 terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason 242 Just action -> do 243 -- Pending actions are executed with read+write locks, just 244 -- like regular handshake code. 245 withWriteLock ctx $ handleException ctx $ 246 case action of 247 PendingAction needAligned pa -> do 248 when needAligned $ checkAlignment hs 249 processHandshake13 ctx h >> pa h 250 PendingActionHash needAligned pa -> do 251 when needAligned $ checkAlignment hs 252 d <- transcriptHash ctx 253 processHandshake13 ctx h 254 pa d h 255 loopHandshake13 hs 256 257 terminate = terminateWithWriteLock ctx (sendPacket13 ctx . Alert13) 258 259 checkAlignment hs = do 260 complete <- isRecvComplete ctx 261 unless (complete && null hs) $ 262 let reason = "received message not aligned with record boundary" 263 in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason 264 265-- the other side could have close the connection already, so wrap 266-- this in a try and ignore all exceptions 267tryBye :: Context -> IO () 268tryBye ctx = catchException (bye ctx) (\_ -> return ()) 269 270onError :: Monad m => (TLSError -> AlertLevel -> AlertDescription -> String -> m B.ByteString) 271 -> TLSError -> m B.ByteString 272onError _ Error_EOF = -- Not really an error. 273 return B.empty 274onError terminate err@(Error_Protocol (reason,fatal,desc)) = 275 terminate err (if fatal then AlertLevel_Fatal else AlertLevel_Warning) desc reason 276onError terminate err = 277 terminate err AlertLevel_Fatal InternalError (show err) 278 279terminateWithWriteLock :: Context -> ([(AlertLevel, AlertDescription)] -> IO ()) 280 -> TLSError -> AlertLevel -> AlertDescription -> String -> IO a 281terminateWithWriteLock ctx send err level desc reason = do 282 session <- usingState_ ctx getSession 283 -- Session manager is always invoked with read+write locks, so we merge this 284 -- with the alert packet being emitted. 285 withWriteLock ctx $ do 286 case session of 287 Session Nothing -> return () 288 Session (Just sid) -> sessionInvalidate (sharedSessionManager $ ctxShared ctx) sid 289 catchException (send [(level, desc)]) (\_ -> return ()) 290 setEOF ctx 291 E.throwIO (Terminated False reason err) 292 293 294{-# DEPRECATED recvData' "use recvData that returns strict bytestring" #-} 295-- | same as recvData but returns a lazy bytestring. 296recvData' :: MonadIO m => Context -> m L.ByteString 297recvData' ctx = L.fromChunks . (:[]) <$> recvData ctx 298 299keyUpdate :: Context 300 -> (Context -> IO (Hash,Cipher,CryptLevel,C8.ByteString)) 301 -> (Context -> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ()) 302 -> IO () 303keyUpdate ctx getState setState = do 304 (usedHash, usedCipher, level, applicationSecretN) <- getState ctx 305 unless (level == CryptApplicationSecret) $ 306 throwCore $ Error_Protocol ("tried key update without application traffic secret", True, InternalError) 307 let applicationSecretN1 = hkdfExpandLabel usedHash applicationSecretN "traffic upd" "" $ hashDigestSize usedHash 308 setState ctx usedHash usedCipher (AnyTrafficSecret applicationSecretN1) 309 310-- | How to update keys in TLS 1.3 311data KeyUpdateRequest = OneWay -- ^ Unidirectional key update 312 | TwoWay -- ^ Bidirectional key update (normal case) 313 deriving (Eq, Show) 314 315-- | Updating appication traffic secrets for TLS 1.3. 316-- If this API is called for TLS 1.3, 'True' is returned. 317-- Otherwise, 'False' is returned. 318updateKey :: MonadIO m => Context -> KeyUpdateRequest -> m Bool 319updateKey ctx way = liftIO $ do 320 tls13 <- tls13orLater ctx 321 when tls13 $ do 322 let req = case way of 323 OneWay -> UpdateNotRequested 324 TwoWay -> UpdateRequested 325 -- Write lock wraps both actions because we don't want another packet to 326 -- be sent by another thread before the Tx state is updated. 327 withWriteLock ctx $ do 328 sendPacket13 ctx $ Handshake13 [KeyUpdate13 req] 329 keyUpdate ctx getTxState setTxState 330 return tls13 331