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