module Network.TLS.Core
(
sendPacket
, recvPacket
, client
, clientWith
, server
, serverWith
, bye
, handshake
, sendData
, recvData
) where
import Network.TLS.Context
import Network.TLS.Struct
import Network.TLS.Record
import Network.TLS.Cipher
import Network.TLS.Compression
import Network.TLS.Packet
import Network.TLS.State
import Network.TLS.Sending
import Network.TLS.Receiving
import Network.TLS.Measurement
import Network.TLS.Wire (encodeWord16)
import Data.Maybe
import Data.List (intersect, find)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Crypto.Random
import Control.Applicative ((<$>))
import Control.Monad.State
import Control.Exception (throwIO, Exception(), fromException, catch)
import System.IO (Handle)
import System.IO.Error (mkIOError, eofErrorType)
import Prelude hiding (catch)
errorToAlert :: TLSError -> Packet
errorToAlert (Error_Protocol (_, _, ad)) = Alert [(AlertLevel_Fatal, ad)]
errorToAlert _ = Alert [(AlertLevel_Fatal, InternalError)]
readExact :: MonadIO m => TLSCtx c -> Int -> m Bytes
readExact ctx sz = do
hdrbs <- liftIO $ connectionRecv ctx sz
when (B.length hdrbs < sz) $ do
setEOF ctx
if B.null hdrbs
then throwCore Error_EOF
else throwCore (Error_Packet ("partial packet: expecting " ++ show sz ++ " bytes, got: " ++ (show $B.length hdrbs)))
return hdrbs
recvRecord :: MonadIO m => TLSCtx c -> m (Either TLSError (Record Plaintext))
recvRecord ctx = readExact ctx 5 >>= either (return . Left) recvLength . decodeHeader
where recvLength header@(Header _ _ readlen)
| readlen > 16384 + 2048 = return $ Left $ Error_Protocol ("record exceeding maximum size", True, RecordOverflow)
| otherwise = do
content <- readExact ctx (fromIntegral readlen)
liftIO $ (loggingIORecv $ ctxLogging ctx) header content
usingState ctx $ disengageRecord $ rawToRecord header (fragmentCiphertext content)
recvPacket :: MonadIO m => TLSCtx c -> m (Either TLSError Packet)
recvPacket ctx = do
erecord <- recvRecord ctx
case erecord of
Left err -> return $ Left err
Right record -> do
pkt <- usingState ctx $ processPacket record
case pkt of
Right p -> liftIO $ (loggingPacketRecv $ ctxLogging ctx) $ show p
_ -> return ()
return pkt
recvPacketHandshake :: MonadIO m => TLSCtx c -> m [Handshake]
recvPacketHandshake ctx = do
pkts <- recvPacket ctx
case pkts of
Right (Handshake l) -> return l
Right x -> fail ("unexpected type received. expecting handshake and got: " ++ show x)
Left err -> throwCore err
data RecvState m =
RecvStateNext (Packet -> m (RecvState m))
| RecvStateHandshake (Handshake -> m (RecvState m))
| RecvStateDone
runRecvState :: MonadIO m => TLSCtx a -> RecvState m -> m ()
runRecvState _ (RecvStateDone) = return ()
runRecvState ctx (RecvStateNext f) = recvPacket ctx >>= either throwCore f >>= runRecvState ctx
runRecvState ctx iniState = recvPacketHandshake ctx >>= loop iniState >>= runRecvState ctx
where
loop :: MonadIO m => RecvState m -> [Handshake] -> m (RecvState m)
loop recvState [] = return recvState
loop (RecvStateHandshake f) (x:xs) = do
nstate <- f x
usingState_ ctx $ processHandshake x
loop nstate xs
loop _ _ = unexpected "spurious handshake" Nothing
sendChangeCipherAndFinish :: MonadIO m => TLSCtx c -> Bool -> m ()
sendChangeCipherAndFinish ctx isClient = do
sendPacket ctx ChangeCipherSpec
liftIO $ connectionFlush ctx
cf <- usingState_ ctx $ getHandshakeDigest isClient
sendPacket ctx (Handshake [Finished cf])
liftIO $ connectionFlush ctx
unexpected :: MonadIO m => String -> Maybe [Char] -> m a
unexpected msg expected = throwCore $ Error_Packet_unexpected msg (maybe "" (" expected: " ++) expected)
sendPacket :: MonadIO m => TLSCtx c -> Packet -> m ()
sendPacket ctx pkt = do
liftIO $ (loggingPacketSent $ ctxLogging ctx) (show pkt)
dataToSend <- usingState_ ctx $ writePacket pkt
liftIO $ (loggingIOSent $ ctxLogging ctx) dataToSend
liftIO $ connectionSend ctx dataToSend
clientWith :: (MonadIO m, CryptoRandomGen g) => TLSParams -> g -> c -> IO () -> (Bytes -> IO ()) -> (Int -> IO Bytes) -> m (TLSCtx c)
clientWith params rng connection flushF sendF recvF =
liftIO $ newCtxWith connection flushF sendF recvF params st
where st = (newTLSState rng) { stClientContext = True }
client :: (MonadIO m, CryptoRandomGen g) => TLSParams -> g -> Handle -> m (TLSCtx Handle)
client params rng handle = liftIO $ newCtx handle params st
where st = (newTLSState rng) { stClientContext = True }
serverWith :: (MonadIO m, CryptoRandomGen g) => TLSParams -> g -> c -> IO () -> (Bytes -> IO ()) -> (Int -> IO Bytes) -> m (TLSCtx c)
serverWith params rng connection flushF sendF recvF =
liftIO $ newCtxWith connection flushF sendF recvF params st
where st = (newTLSState rng) { stClientContext = False }
server :: (MonadIO m, CryptoRandomGen g) => TLSParams -> g -> Handle -> m (TLSCtx Handle)
server params rng handle = liftIO $ newCtx handle params st
where st = (newTLSState rng) { stClientContext = False }
bye :: MonadIO m => TLSCtx c -> m ()
bye ctx = sendPacket ctx $ Alert [(AlertLevel_Warning, CloseNotify)]
handshakeClient :: MonadIO m => TLSCtx c -> m ()
handshakeClient ctx = do
updateMeasure ctx incrementNbHandshakes
sendClientHello
recvServerHello
sendCertificate >> sendClientKeyXchg >> sendCertificateVerify
sendChangeCipherAndFinish ctx True
recvChangeCipherAndFinish
updateMeasure ctx resetBytesCounters
where
params = ctxParams ctx
ver = pConnectVersion params
allowedvers = pAllowedVersions params
ciphers = pCiphers params
compressions = pCompressions params
clientCerts = map fst $ pCertificates params
getExtensions =
if pUseSecureRenegotiation params
then usingState_ ctx (getVerifiedData True) >>= \vd -> return [ (0xff01, encodeExtSecureRenegotiation vd Nothing) ]
else return []
sendClientHello = do
crand <- getStateRNG ctx 32 >>= return . ClientRandom
extensions <- getExtensions
usingState_ ctx (startHandshakeClient ver crand)
sendPacket ctx $ Handshake
[ ClientHello ver crand (Session Nothing) (map cipherID ciphers)
(map compressionID compressions) extensions
]
recvChangeCipherAndFinish = runRecvState ctx (RecvStateNext expectChangeCipher)
where
expectChangeCipher ChangeCipherSpec = return $ RecvStateHandshake expectFinish
expectChangeCipher p = unexpected (show p) (Just "change cipher")
expectFinish (Finished _) = return RecvStateDone
expectFinish p = unexpected (show p) (Just "Handshake Finished")
sendCertificate = do
certRequested <- return False
when certRequested (sendPacket ctx $ Handshake [Certificates clientCerts])
sendCertificateVerify =
return ()
recvServerHello = runRecvState ctx (RecvStateHandshake processServerHello)
processServerHello :: MonadIO m => Handshake -> m (RecvState m)
processServerHello (ServerHello rver _ _ cipher _ _) = do
when (rver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion)
case find ((==) rver) allowedvers of
Nothing -> throwCore $ Error_Protocol ("version " ++ show ver ++ "is not supported", True, ProtocolVersion)
Just _ -> usingState_ ctx $ setVersion ver
case find ((==) cipher . cipherID) ciphers of
Nothing -> throwCore $ Error_Protocol ("no cipher in common with the server", True, HandshakeFailure)
Just c -> usingState_ ctx $ setCipher c
return $ RecvStateHandshake processCertificate
processServerHello p = unexpected (show p) (Just "server hello")
processCertificate :: MonadIO m => Handshake -> m (RecvState m)
processCertificate (Certificates certs) = do
let cb = onCertificatesRecv $ params
usage <- liftIO $ cb certs
case usage of
CertificateUsageAccept -> return ()
CertificateUsageReject reason -> certificateRejected reason
return $ RecvStateHandshake processServerKeyExchange
processCertificate p = processServerKeyExchange p
processServerKeyExchange :: MonadIO m => Handshake -> m (RecvState m)
processServerKeyExchange (ServerKeyXchg _) = return $ RecvStateHandshake processCertificateRequest
processServerKeyExchange p = processCertificateRequest p
processCertificateRequest (CertRequest _ _ _) = do
return $ RecvStateHandshake processServerHelloDone
processCertificateRequest p = processServerHelloDone p
processServerHelloDone ServerHelloDone = return RecvStateDone
processServerHelloDone p = unexpected (show p) (Just "server hello data")
sendClientKeyXchg = do
encryptedPreMaster <- usingState_ ctx $ do
xver <- stVersion <$> get
prerand <- genTLSRandom 46
let premaster = encodePreMasterSecret xver prerand
setMasterSecret premaster
e <- encryptRSA premaster
let extra = if xver < TLS10
then B.empty
else encodeWord16 $ fromIntegral $ B.length e
return $ extra `B.append` e
sendPacket ctx $ Handshake [ClientKeyXchg encryptedPreMaster]
certificateRejected CertificateRejectRevoked =
throwCore $ Error_Protocol ("certificate is revoked", True, CertificateRevoked)
certificateRejected CertificateRejectExpired =
throwCore $ Error_Protocol ("certificate has expired", True, CertificateExpired)
certificateRejected CertificateRejectUnknownCA =
throwCore $ Error_Protocol ("certificate has unknown CA", True, UnknownCa)
certificateRejected (CertificateRejectOther s) =
throwCore $ Error_Protocol ("certificate rejected: " ++ s, True, CertificateUnknown)
handshakeServerWith :: MonadIO m => TLSCtx c -> Handshake -> m ()
handshakeServerWith ctx clientHello@(ClientHello ver _ _ ciphers compressions _) = do
handshakeAuthorized <- withMeasure ctx (onHandshake $ ctxParams ctx)
unless handshakeAuthorized (throwCore $ Error_HandshakePolicy "server: handshake denied")
updateMeasure ctx incrementNbHandshakes
usingState_ ctx $ processHandshake clientHello
when (ver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion)
when (not $ elem ver (pAllowedVersions params)) $
throwCore $ Error_Protocol ("version " ++ show ver ++ "is not supported", True, ProtocolVersion)
when (commonCiphers == []) $
throwCore $ Error_Protocol ("no cipher in common with the client", True, HandshakeFailure)
when (null commonCompressions) $
throwCore $ Error_Protocol ("no compression in common with the client", True, HandshakeFailure)
usingState_ ctx $ modify (\st -> st
{ stVersion = ver
, stCipher = Just usedCipher
, stCompression = usedCompression
})
handshakeSendServerData
liftIO $ connectionFlush ctx
recvClientData
sendChangeCipherAndFinish ctx False
updateMeasure ctx resetBytesCounters
return ()
where
params = ctxParams ctx
commonCiphers = intersect ciphers (map cipherID $ pCiphers params)
usedCipher = fromJust $ find (\c -> cipherID c == head commonCiphers) (pCiphers params)
commonCompressions = compressionIntersectID (pCompressions params) compressions
usedCompression = head commonCompressions
srvCerts = map fst $ pCertificates params
privKeys = map snd $ pCertificates params
needKeyXchg = cipherExchangeNeedMoreData $ cipherKeyExchange usedCipher
recvClientData = runRecvState ctx (RecvStateHandshake $ processClientCertificate)
processClientCertificate (Certificates _) = return $ RecvStateHandshake processClientKeyExchange
processClientCertificate p = processClientKeyExchange p
processClientKeyExchange (ClientKeyXchg _) = return $ RecvStateNext processCertificateVerify
processClientKeyExchange p = unexpected (show p) (Just "client key exchange")
processCertificateVerify (Handshake [CertVerify _]) = return $ RecvStateNext expectChangeCipher
processCertificateVerify p = expectChangeCipher p
expectChangeCipher ChangeCipherSpec = return $ RecvStateHandshake expectFinish
expectChangeCipher p = unexpected (show p) (Just "change cipher")
expectFinish (Finished _) = return RecvStateDone
expectFinish p = unexpected (show p) (Just "Handshake Finished")
handshakeSendServerData = do
srand <- getStateRNG ctx 32 >>= return . ServerRandom
case privKeys of
(Just privkey : _) -> usingState_ ctx $ setPrivateKey privkey
_ -> return ()
secReneg <- usingState_ ctx getSecureRenegotiation
extensions <- if secReneg
then do
vf <- usingState_ ctx $ do
cvf <- getVerifiedData True
svf <- getVerifiedData False
return $ encodeExtSecureRenegotiation cvf (Just svf)
return [ (0xff01, vf) ]
else return []
usingState_ ctx (setVersion ver >> setServerRandom srand)
sendPacket ctx $ Handshake
[ ServerHello ver srand (Session Nothing) (cipherID usedCipher)
(compressionID usedCompression) extensions
, Certificates srvCerts
]
when needKeyXchg $ do
let skg = SKX_RSA Nothing
sendPacket ctx (Handshake [ServerKeyXchg skg])
when (pWantClientCert params) $ do
let certTypes = [ CertificateType_RSA_Sign ]
let creq = CertRequest certTypes Nothing [0,0,0]
sendPacket ctx (Handshake [creq])
sendPacket ctx (Handshake [ServerHelloDone])
handshakeServerWith _ _ = fail "unexpected handshake type received. expecting client hello"
handshakeServer :: MonadIO m => TLSCtx c -> m ()
handshakeServer ctx = do
pkts <- recvPacket ctx
case pkts of
Right (Handshake [hs]) -> handshakeServerWith ctx hs
x -> fail ("unexpected type received. expecting handshake ++ " ++ show x)
handshake :: MonadIO m => TLSCtx c -> m Bool
handshake ctx = do
cc <- usingState_ ctx (stClientContext <$> get)
liftIO $ handleException $ if cc then handshakeClient ctx else handshakeServer ctx
where
handleException f = catch (f >> return True) (\e -> handler e >> return False)
handler e = case fromException e of
Just err -> sendPacket ctx (errorToAlert err)
Nothing -> sendPacket ctx (errorToAlert $ Error_Misc $ show e)
sendData :: MonadIO m => TLSCtx c -> L.ByteString -> m ()
sendData ctx dataToSend = do
eofed <- ctxEOF ctx
when eofed $ liftIO $ throwIO $ mkIOError eofErrorType "sendData" Nothing Nothing
mapM_ sendDataChunk (L.toChunks dataToSend)
where sendDataChunk d = if B.length d > 16384
then do
let (sending, remain) = B.splitAt 16384 d
sendPacket ctx $ AppData sending
sendDataChunk remain
else
sendPacket ctx $ AppData d
recvData :: MonadIO m => TLSCtx c -> m L.ByteString
recvData ctx = do
eofed <- ctxEOF ctx
when eofed $ liftIO $ throwIO $ mkIOError eofErrorType "recvData" Nothing Nothing
pkt <- recvPacket ctx
case pkt of
Right (Handshake [ch@(ClientHello _ _ _ _ _ _)]) ->
handshakeServerWith ctx ch >> recvData ctx
Right (Handshake [HelloRequest]) ->
handshakeClient ctx >> recvData ctx
Right (Alert [(AlertLevel_Fatal, _)]) -> do
setEOF ctx
return L.empty
Right (Alert [(AlertLevel_Warning, CloseNotify)]) -> do
setEOF ctx
return L.empty
Right (AppData x) -> return $ L.fromChunks [x]
Right p -> error ("error unexpected packet: " ++ show p)
Left err -> error ("error received: " ++ show err)