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) 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 mapM_ (mapChunks_ 16384 sendP) (L.toChunks dataToSend) 105 106-- | Get data out of Data packet, and automatically renegotiate if a Handshake 107-- ClientHello is received. An empty result means EOF. 108recvData :: MonadIO m => Context -> m B.ByteString 109recvData ctx = liftIO $ do 110 tls13 <- tls13orLater ctx 111 withReadLock ctx $ do 112 checkValid ctx 113 -- We protect with a read lock both reception and processing of the 114 -- packet, because don't want another thread to receive a new packet 115 -- before this one has been fully processed. 116 -- 117 -- Even when recvData1/recvData13 loops, we only need to call function 118 -- checkValid once. Since we hold the read lock, no concurrent call 119 -- will impact the validity of the context. 120 if tls13 then recvData13 ctx else recvData1 ctx 121 122recvData1 :: Context -> IO B.ByteString 123recvData1 ctx = do 124 pkt <- recvPacket ctx 125 either (onError terminate) process pkt 126 where process (Handshake [ch@ClientHello{}]) = 127 handshakeWith ctx ch >> recvData1 ctx 128 process (Handshake [hr@HelloRequest]) = 129 handshakeWith ctx hr >> recvData1 ctx 130 131 process (Alert [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx >> return B.empty 132 process (Alert [(AlertLevel_Fatal, desc)]) = do 133 setEOF ctx 134 E.throwIO (Terminated True ("received fatal error: " ++ show desc) (Error_Protocol ("remote side fatal error", True, desc))) 135 136 -- when receiving empty appdata, we just retry to get some data. 137 process (AppData "") = recvData1 ctx 138 process (AppData x) = return x 139 process p = let reason = "unexpected message " ++ show p in 140 terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason 141 142 terminate = terminateWithWriteLock ctx (sendPacket ctx . Alert) 143 144recvData13 :: Context -> IO B.ByteString 145recvData13 ctx = do 146 pkt <- recvPacket13 ctx 147 either (onError terminate) process pkt 148 where process (Alert13 [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx >> return B.empty 149 process (Alert13 [(AlertLevel_Fatal, desc)]) = do 150 setEOF ctx 151 E.throwIO (Terminated True ("received fatal error: " ++ show desc) (Error_Protocol ("remote side fatal error", True, desc))) 152 process (Handshake13 hs) = do 153 loopHandshake13 hs 154 recvData13 ctx 155 -- when receiving empty appdata, we just retry to get some data. 156 process (AppData13 "") = recvData13 ctx 157 process (AppData13 x) = do 158 let chunkLen = C8.length x 159 established <- ctxEstablished ctx 160 case established of 161 EarlyDataAllowed maxSize 162 | chunkLen <= maxSize -> do 163 setEstablished ctx $ EarlyDataAllowed (maxSize - chunkLen) 164 return x 165 | otherwise -> 166 let reason = "early data overflow" in 167 terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason 168 EarlyDataNotAllowed n 169 | n > 0 -> do 170 setEstablished ctx $ EarlyDataNotAllowed (n - 1) 171 recvData13 ctx -- ignore "x" 172 | otherwise -> 173 let reason = "early data deprotect overflow" in 174 terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason 175 Established -> return x 176 NotEstablished -> throwCore $ Error_Protocol ("data at not-established", True, UnexpectedMessage) 177 process ChangeCipherSpec13 = recvData13 ctx 178 process p = let reason = "unexpected message " ++ show p in 179 terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason 180 181 loopHandshake13 [] = return () 182 loopHandshake13 (ClientHello13{}:_) = do 183 let reason = "Client hello is not allowed" 184 terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason 185 -- fixme: some implementations send multiple NST at the same time. 186 -- Only the first one is used at this moment. 187 loopHandshake13 (NewSessionTicket13 life add nonce label exts:hs) = do 188 role <- usingState_ ctx S.isClientContext 189 unless (role == ClientRole) $ 190 let reason = "Session ticket is allowed for client only" 191 in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason 192 -- This part is similar to handshake code, so protected with 193 -- read+write locks (which is also what we use for all calls to the 194 -- session manager). 195 withWriteLock ctx $ do 196 Just resumptionMasterSecret <- usingHState ctx getTLS13ResumptionSecret 197 (_, usedCipher, _) <- getTxState ctx 198 let choice = makeCipherChoice TLS13 usedCipher 199 psk = derivePSK choice resumptionMasterSecret nonce 200 maxSize = case extensionLookup extensionID_EarlyData exts >>= extensionDecode MsgTNewSessionTicket of 201 Just (EarlyDataIndication (Just ms)) -> fromIntegral $ safeNonNegative32 ms 202 _ -> 0 203 life7d = min life 604800 -- 7 days max 204 tinfo <- createTLS13TicketInfo life7d (Right add) Nothing 205 sdata <- getSessionData13 ctx usedCipher tinfo maxSize psk 206 let !label' = B.copy label 207 sessionEstablish (sharedSessionManager $ ctxShared ctx) label' sdata 208 -- putStrLn $ "NewSessionTicket received: lifetime = " ++ show life ++ " sec" 209 loopHandshake13 hs 210 loopHandshake13 (KeyUpdate13 mode:hs) = do 211 checkAlignment hs 212 established <- ctxEstablished ctx 213 -- Though RFC 8446 Sec 4.6.3 does not clearly says, 214 -- unidirectional key update is legal. 215 -- So, we don't have to check if this key update is corresponding 216 -- to key update (update_requested) which we sent. 217 if established == Established then do 218 keyUpdate ctx getRxState setRxState 219 -- Write lock wraps both actions because we don't want another 220 -- packet to be sent by another thread before the Tx state is 221 -- updated. 222 when (mode == UpdateRequested) $ withWriteLock ctx $ do 223 sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested] 224 keyUpdate ctx getTxState setTxState 225 loopHandshake13 hs 226 else do 227 let reason = "received key update before established" 228 terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason 229 loopHandshake13 (h@CertRequest13{}:hs) = 230 postHandshakeAuthWith ctx h >> loopHandshake13 hs 231 loopHandshake13 (h@Certificate13{}:hs) = 232 postHandshakeAuthWith ctx h >> loopHandshake13 hs 233 loopHandshake13 (h:hs) = do 234 mPendingAction <- popPendingAction ctx 235 case mPendingAction of 236 Nothing -> let reason = "unexpected handshake message " ++ show h in 237 terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason 238 Just action -> do 239 -- Pending actions are executed with read+write locks, just 240 -- like regular handshake code. 241 withWriteLock ctx $ handleException ctx $ 242 case action of 243 PendingAction needAligned pa -> do 244 when needAligned $ checkAlignment hs 245 processHandshake13 ctx h >> pa h 246 PendingActionHash needAligned pa -> do 247 when needAligned $ checkAlignment hs 248 d <- transcriptHash ctx 249 processHandshake13 ctx h 250 pa d h 251 loopHandshake13 hs 252 253 terminate = terminateWithWriteLock ctx (sendPacket13 ctx . Alert13) 254 255 checkAlignment hs = do 256 complete <- isRecvComplete ctx 257 unless (complete && null hs) $ 258 let reason = "received message not aligned with record boundary" 259 in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason 260 261-- the other side could have close the connection already, so wrap 262-- this in a try and ignore all exceptions 263tryBye :: Context -> IO () 264tryBye ctx = catchException (bye ctx) (\_ -> return ()) 265 266onError :: Monad m => (TLSError -> AlertLevel -> AlertDescription -> String -> m B.ByteString) 267 -> TLSError -> m B.ByteString 268onError _ Error_EOF = -- Not really an error. 269 return B.empty 270onError terminate err@(Error_Protocol (reason,fatal,desc)) = 271 terminate err (if fatal then AlertLevel_Fatal else AlertLevel_Warning) desc reason 272onError terminate err = 273 terminate err AlertLevel_Fatal InternalError (show err) 274 275terminateWithWriteLock :: Context -> ([(AlertLevel, AlertDescription)] -> IO ()) 276 -> TLSError -> AlertLevel -> AlertDescription -> String -> IO a 277terminateWithWriteLock ctx send err level desc reason = do 278 session <- usingState_ ctx getSession 279 -- Session manager is always invoked with read+write locks, so we merge this 280 -- with the alert packet being emitted. 281 withWriteLock ctx $ do 282 case session of 283 Session Nothing -> return () 284 Session (Just sid) -> sessionInvalidate (sharedSessionManager $ ctxShared ctx) sid 285 catchException (send [(level, desc)]) (\_ -> return ()) 286 setEOF ctx 287 E.throwIO (Terminated False reason err) 288 289 290{-# DEPRECATED recvData' "use recvData that returns strict bytestring" #-} 291-- | same as recvData but returns a lazy bytestring. 292recvData' :: MonadIO m => Context -> m L.ByteString 293recvData' ctx = L.fromChunks . (:[]) <$> recvData ctx 294 295keyUpdate :: Context 296 -> (Context -> IO (Hash,Cipher,C8.ByteString)) 297 -> (Context -> Hash -> Cipher -> C8.ByteString -> IO ()) 298 -> IO () 299keyUpdate ctx getState setState = do 300 (usedHash, usedCipher, applicationSecretN) <- getState ctx 301 let applicationSecretN1 = hkdfExpandLabel usedHash applicationSecretN "traffic upd" "" $ hashDigestSize usedHash 302 setState ctx usedHash usedCipher applicationSecretN1 303 304-- | How to update keys in TLS 1.3 305data KeyUpdateRequest = OneWay -- ^ Unidirectional key update 306 | TwoWay -- ^ Bidirectional key update (normal case) 307 deriving (Eq, Show) 308 309-- | Updating appication traffic secrets for TLS 1.3. 310-- If this API is called for TLS 1.3, 'True' is returned. 311-- Otherwise, 'False' is returned. 312updateKey :: MonadIO m => Context -> KeyUpdateRequest -> m Bool 313updateKey ctx way = liftIO $ do 314 tls13 <- tls13orLater ctx 315 when tls13 $ do 316 let req = case way of 317 OneWay -> UpdateNotRequested 318 TwoWay -> UpdateRequested 319 -- Write lock wraps both actions because we don't want another packet to 320 -- be sent by another thread before the Tx state is updated. 321 withWriteLock ctx $ do 322 sendPacket13 ctx $ Handshake13 [KeyUpdate13 req] 323 keyUpdate ctx getTxState setTxState 324 return tls13 325