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