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