{-# OPTIONS_HADDOCK hide #-}{-# LANGUAGE DeriveDataTypeable #-}-- |-- Module : Network.TLS.Core-- License : BSD-style-- Maintainer : Vincent Hanquez <vincent@snarc.org>-- Stability : experimental-- Portability : unknown--moduleNetwork.TLS.Core(-- * Internal packet sending and receivingsendPacket,recvPacket-- * Creating a client or server context,client,clientWith,server,serverWith-- * Initialisation and Termination of context,bye,handshake,HandshakeFailed(..),ConnectionNotEstablished(..)-- * High level API,sendData,recvData,recvData')whereimportNetwork.TLS.ContextimportNetwork.TLS.StructimportNetwork.TLS.RecordimportNetwork.TLS.CipherimportNetwork.TLS.CompressionimportNetwork.TLS.PacketimportNetwork.TLS.StateimportNetwork.TLS.SendingimportNetwork.TLS.ReceivingimportNetwork.TLS.MeasurementimportNetwork.TLS.Wire(encodeWord16)importData.MaybeimportData.DataimportData.List(intersect,find)importqualifiedData.ByteStringasBimportqualifiedData.ByteString.LazyasLimportCrypto.RandomimportControl.Applicative((<$>))importControl.Monad.StateimportControl.Exception(throwIO,Exception(),fromException,catch,SomeException)importSystem.IO(Handle)importSystem.IO.Error(mkIOError,eofErrorType)importPreludehiding(catch)dataHandshakeFailed=HandshakeFailedTLSErrorderiving(Show,Eq,Typeable)dataConnectionNotEstablished=ConnectionNotEstablishedderiving(Show,Eq,Typeable)instanceExceptionHandshakeFailedinstanceExceptionConnectionNotEstablishederrorToAlert::TLSError->PacketerrorToAlert(Error_Protocol(_,_,ad))=Alert[(AlertLevel_Fatal,ad)]errorToAlert_=Alert[(AlertLevel_Fatal,InternalError)]handshakeFailed::TLSError->IO()handshakeFailederr=throwIO$HandshakeFailederrcheckValid::MonadIOm=>TLSCtxc->m()checkValidctx=doestablished<-ctxEstablishedctxunlessestablished$liftIO$throwIOConnectionNotEstablishedeofed<-ctxEOFctxwheneofed$liftIO$throwIO$mkIOErroreofErrorType"data"NothingNothingreadExact::MonadIOm=>TLSCtxc->Int->mBytesreadExactctxsz=dohdrbs<-liftIO$connectionRecvctxszwhen(B.lengthhdrbs<sz)$dosetEOFctxifB.nullhdrbsthenthrowCoreError_EOFelsethrowCore(Error_Packet("partial packet: expecting "++showsz++" bytes, got: "++(show$B.lengthhdrbs)))returnhdrbsrecvRecord::MonadIOm=>TLSCtxc->m(EitherTLSError(RecordPlaintext))recvRecordctx=readExactctx5>>=either(return.Left)recvLength.decodeHeaderwhererecvLengthheader@(Header__readlen)|readlen>16384+2048=return$Left$Error_Protocol("record exceeding maximum size",True,RecordOverflow)|otherwise=docontent<-readExactctx(fromIntegralreadlen)liftIO$(loggingIORecv$ctxLoggingctx)headercontentusingStatectx$disengageRecord$rawToRecordheader(fragmentCiphertextcontent)-- | receive one packet from the context that contains 1 or-- many messages (many only in case of handshake). if will returns a-- TLSError if the packet is unexpected or malformedrecvPacket::MonadIOm=>TLSCtxc->m(EitherTLSErrorPacket)recvPacketctx=doerecord<-recvRecordctxcaseerecordofLefterr->return$LefterrRightrecord->dopkt<-usingStatectx$processPacketrecordcasepktofRightp->liftIO$(loggingPacketRecv$ctxLoggingctx)$showp_->return()returnpktrecvPacketHandshake::MonadIOm=>TLSCtxc->m[Handshake]recvPacketHandshakectx=dopkts<-recvPacketctxcasepktsofRight(Handshakel)->returnlRightx->fail("unexpected type received. expecting handshake and got: "++showx)Lefterr->throwCoreerrdataRecvStatem=RecvStateNext(Packet->m(RecvStatem))|RecvStateHandshake(Handshake->m(RecvStatem))|RecvStateDonerunRecvState::MonadIOm=>TLSCtxa->RecvStatem->m()runRecvState_(RecvStateDone)=return()runRecvStatectx(RecvStateNextf)=recvPacketctx>>=eitherthrowCoref>>=runRecvStatectxrunRecvStatectxiniState=recvPacketHandshakectx>>=loopiniState>>=runRecvStatectxwhereloop::MonadIOm=>RecvStatem->[Handshake]->m(RecvStatem)looprecvState[]=returnrecvStateloop(RecvStateHandshakef)(x:xs)=donstate<-fxusingState_ctx$processHandshakexloopnstatexsloop__=unexpected"spurious handshake"NothingsendChangeCipherAndFinish::MonadIOm=>TLSCtxc->Bool->m()sendChangeCipherAndFinishctxisClient=dosendPacketctxChangeCipherSpecliftIO$connectionFlushctxcf<-usingState_ctx$getHandshakeDigestisClientsendPacketctx(Handshake[Finishedcf])liftIO$connectionFlushctxrecvChangeCipherAndFinish::MonadIOm=>TLSCtxc->m()recvChangeCipherAndFinishctx=runRecvStatectx(RecvStateNextexpectChangeCipher)whereexpectChangeCipherChangeCipherSpec=return$RecvStateHandshakeexpectFinishexpectChangeCipherp=unexpected(showp)(Just"change cipher")expectFinish(Finished_)=returnRecvStateDoneexpectFinishp=unexpected(showp)(Just"Handshake Finished")unexpected::MonadIOm=>String->Maybe[Char]->maunexpectedmsgexpected=throwCore$Error_Packet_unexpectedmsg(maybe""(" expected: "++)expected)newSession::MonadIOm=>TLSCtxc->mSessionnewSessionctx|pUseSession$ctxParamsctx=getStateRNGctx32>>=return.Session.Just|otherwise=return$SessionNothing-- | Send one packet to the contextsendPacket::MonadIOm=>TLSCtxc->Packet->m()sendPacketctxpkt=doliftIO$(loggingPacketSent$ctxLoggingctx)(showpkt)dataToSend<-usingState_ctx$writePacketpktliftIO$(loggingIOSent$ctxLoggingctx)dataToSendliftIO$connectionSendctxdataToSend-- | Create a new Client context with a configuration, a RNG, a generic connection and the connection operation.clientWith::(MonadIOm,CryptoRandomGeng)=>TLSParams-- ^ Parameters to use for this context->g-- ^ Random number generator associated->c-- ^ An abstract connection type->IO()-- ^ A method for the connection buffer to be flushed->(B.ByteString->IO())-- ^ A method for sending bytes through the connection->(Int->IOB.ByteString)-- ^ A method for receiving bytes through the connection->m(TLSCtxc)clientWithparamsrngconnectionflushFsendFrecvF=liftIO$newCtxWithconnectionflushFsendFrecvFparamsstwherest=(newTLSStaterng){stClientContext=True}-- | Create a new Client context with a configuration, a RNG, and a Handle.-- It reconfigures the handle's 'System.IO.BufferMode' to @NoBuffering@.client::(MonadIOm,CryptoRandomGeng)=>TLSParams-- ^ parameters to use for this context->g-- ^ random number generator associated with the context->Handle-- ^ handle to use->m(TLSCtxHandle)clientparamsrnghandle=liftIO$newCtxhandleparamsstwherest=(newTLSStaterng){stClientContext=True}-- | Create a new Server context with a configuration, a RNG, a generic connection and the connection operation.serverWith::(MonadIOm,CryptoRandomGeng)=>TLSParams->g->c->IO()->(B.ByteString->IO())->(Int->IOB.ByteString)->m(TLSCtxc)serverWithparamsrngconnectionflushFsendFrecvF=liftIO$newCtxWithconnectionflushFsendFrecvFparamsstwherest=(newTLSStaterng){stClientContext=False}-- | Create a new Server context with a configuration, a RNG, and a Handle.-- It reconfigures the handle's 'System.IO.BufferMode' to @NoBuffering@.server::(MonadIOm,CryptoRandomGeng)=>TLSParams->g->Handle->m(TLSCtxHandle)serverparamsrnghandle=liftIO$newCtxhandleparamsstwherest=(newTLSStaterng){stClientContext=False}-- | notify the context that this side wants to close connection.-- this is important that it is called before closing the handle, otherwise-- the session might not be resumable (for version < TLS1.2).---- this doesn't actually close the handlebye::MonadIOm=>TLSCtxc->m()byectx=sendPacketctx$Alert[(AlertLevel_Warning,CloseNotify)]-- | when a new handshake is done, wrap up & clean up.handshakeTerminate::MonadIOm=>TLSCtxc->m()handshakeTerminatectx=dosession<-usingState_ctxgetSession-- only callback the session established if we have a sessioncasesessionofSession(JustsessionId)->dosessionData<-usingState_ctxgetSessionDataliftIO$(onSessionEstablished$ctxParamsctx)sessionId(fromJustsessionData)_->return()-- forget all handshake data now and reset bytes counters.usingState_ctxendHandshakeupdateMeasurectxresetBytesCounters-- mark the secure connection up and running.setEstablishedctxTruereturn()-- client part of handshake. send a bunch of handshake of client-- values intertwined with response from the server.handshakeClient::MonadIOm=>TLSCtxc->m()handshakeClientctx=doupdateMeasurectxincrementNbHandshakessendClientHellorecvServerHellosessionResuming<-usingState_ctxisSessionResumingifsessionResumingthensendChangeCipherAndFinishctxTrueelsedosendCertificate>>sendClientKeyXchg>>sendCertificateVerifysendChangeCipherAndFinishctxTruerecvChangeCipherAndFinishctxhandshakeTerminatectxwhereparams=ctxParamsctxver=pConnectVersionparamsallowedvers=pAllowedVersionsparamsciphers=pCiphersparamscompressions=pCompressionsparamsclientCerts=mapfst$pCertificatesparamsgetExtensions=ifpUseSecureRenegotiationparamsthenusingState_ctx(getVerifiedDataTrue)>>=\vd->return[(0xff01,encodeExtSecureRenegotiationvdNothing)]elsereturn[]sendClientHello=docrand<-getStateRNGctx32>>=return.ClientRandomletclientSession=Session.maybeNothing(Just.fst)$sessionResumeWithparamsextensions<-getExtensionsusingState_ctx(startHandshakeClientvercrand)sendPacketctx$Handshake[ClientHellovercrandclientSession(mapcipherIDciphers)(mapcompressionIDcompressions)extensions]expectChangeCipherChangeCipherSpec=return$RecvStateHandshakeexpectFinishexpectChangeCipherp=unexpected(showp)(Just"change cipher")expectFinish(Finished_)=returnRecvStateDoneexpectFinishp=unexpected(showp)(Just"Handshake Finished")sendCertificate=do-- Send Certificate if requested. XXX disabled for now.certRequested<-returnFalsewhencertRequested(sendPacketctx$Handshake[CertificatesclientCerts])sendCertificateVerify={- maybe send certificateVerify -}{- FIXME not implemented yet -}return()recvServerHello=runRecvStatectx(RecvStateHandshakeonServerHello)onServerHello::MonadIOm=>Handshake->m(RecvStatem)onServerHellosh@(ServerHellorver_serverSessioncipher__)=dowhen(rver==SSL2)$throwCore$Error_Protocol("ssl2 is not supported",True,ProtocolVersion)casefind((==)rver)allowedversofNothing->throwCore$Error_Protocol("version "++showver++"is not supported",True,ProtocolVersion)Just_->usingState_ctx$setVersionvercasefind((==)cipher.cipherID)ciphersofNothing->throwCore$Error_Protocol("no cipher in common with the server",True,HandshakeFailure)Justc->usingState_ctx$setCiphercletresumingSession=casesessionResumeWithparamsofJust(sessionId,sessionData)->ifserverSession==Session(JustsessionId)thenJustsessionDataelseNothingNothing->NothingusingState_ctx$setSessionserverSession(isJustresumingSession)usingState_ctx$processServerHelloshcaseresumingSessionofNothing->return$RecvStateHandshakeprocessCertificateJustsessionData->dousingState_ctx(setMasterSecret$sessionSecretsessionData)return$RecvStateNextexpectChangeCipheronServerHellop=unexpected(showp)(Just"server hello")processCertificate::MonadIOm=>Handshake->m(RecvStatem)processCertificate(Certificatescerts)=dousage<-liftIO$catch(onCertificatesRecvparams$certs)rejectOnExceptioncaseusageofCertificateUsageAccept->return()CertificateUsageRejectreason->certificateRejectedreasonreturn$RecvStateHandshakeprocessServerKeyExchangewhererejectOnException::SomeException->IOTLSCertificateUsagerejectOnExceptione=return$CertificateUsageReject$CertificateRejectOther$showeprocessCertificatep=processServerKeyExchangepprocessServerKeyExchange::MonadIOm=>Handshake->m(RecvStatem)processServerKeyExchange(ServerKeyXchg_)=return$RecvStateHandshakeprocessCertificateRequestprocessServerKeyExchangep=processCertificateRequestpprocessCertificateRequest(CertRequest___)=do--modify (\sc -> sc { scCertRequested = True })return$RecvStateHandshakeprocessServerHelloDoneprocessCertificateRequestp=processServerHelloDonepprocessServerHelloDoneServerHelloDone=returnRecvStateDoneprocessServerHelloDonep=unexpected(showp)(Just"server hello data")sendClientKeyXchg=doencryptedPreMaster<-usingState_ctx$doxver<-stVersion<$>getprerand<-genTLSRandom46letpremaster=encodePreMasterSecretxverprerandsetMasterSecretFromPrepremaster-- SSL3 implementation generally forget this length field since it's redundant,-- however TLS10 make it clear that the length field need to be present.e<-encryptRSApremasterletextra=ifxver<TLS10thenB.emptyelseencodeWord16$fromIntegral$B.lengthereturn$extra`B.append`esendPacketctx$Handshake[ClientKeyXchgencryptedPreMaster]-- on certificate reject, throw an exception with the proper protocol alert error.certificateRejectedCertificateRejectRevoked=throwCore$Error_Protocol("certificate is revoked",True,CertificateRevoked)certificateRejectedCertificateRejectExpired=throwCore$Error_Protocol("certificate has expired",True,CertificateExpired)certificateRejectedCertificateRejectUnknownCA=throwCore$Error_Protocol("certificate has unknown CA",True,UnknownCa)certificateRejected(CertificateRejectOthers)=throwCore$Error_Protocol("certificate rejected: "++s,True,CertificateUnknown)handshakeServerWith::MonadIOm=>TLSCtxc->Handshake->m()handshakeServerWithctxclientHello@(ClientHellover_clientSessioncipherscompressions_)=do-- check if policy allow this new handshake to happenshandshakeAuthorized<-withMeasurectx(onHandshake$ctxParamsctx)unlesshandshakeAuthorized(throwCore$Error_HandshakePolicy"server: handshake denied")updateMeasurectxincrementNbHandshakes-- Handle Client hellousingState_ctx$processHandshakeclientHellowhen(ver==SSL2)$throwCore$Error_Protocol("ssl2 is not supported",True,ProtocolVersion)when(not$elemver(pAllowedVersionsparams))$throwCore$Error_Protocol("version "++showver++"is not supported",True,ProtocolVersion)when(commonCiphers==[])$throwCore$Error_Protocol("no cipher in common with the client",True,HandshakeFailure)when(nullcommonCompressions)$throwCore$Error_Protocol("no compression in common with the client",True,HandshakeFailure)usingState_ctx$modify(\st->st{stVersion=ver,stCipher=JustusedCipher,stCompression=usedCompression})resumeSessionData<-caseclientSessionof(Session(JustclientSessionId))->liftIO$onSessionResumptionparams$clientSessionId(SessionNothing)->returnNothingcaseresumeSessionDataofNothing->dohandshakeSendServerDataliftIO$connectionFlushctx-- Receive client info until client Finished.recvClientDatasendChangeCipherAndFinishctxFalseJustsessionData->dousingState_ctx(setSessionclientSessionTrue)serverhello<-makeServerHelloclientSessionsendPacketctx$Handshake[serverhello]usingState_ctx$setMasterSecret$sessionSecretsessionDatasendChangeCipherAndFinishctxFalserecvChangeCipherAndFinishctxhandshakeTerminatectxwhereparams=ctxParamsctxcommonCiphers=intersectciphers(mapcipherID$pCiphersparams)usedCipher=fromJust$find(\c->cipherIDc==headcommonCiphers)(pCiphersparams)commonCompressions=compressionIntersectID(pCompressionsparams)compressionsusedCompression=headcommonCompressionssrvCerts=mapfst$pCertificatesparamsprivKeys=mapsnd$pCertificatesparamsneedKeyXchg=cipherExchangeNeedMoreData$cipherKeyExchangeusedCipher---recvClientData=runRecvStatectx(RecvStateHandshake$processClientCertificate)processClientCertificate(Certificates_)=return$RecvStateHandshakeprocessClientKeyExchangeprocessClientCertificatep=processClientKeyExchangepprocessClientKeyExchange(ClientKeyXchg_)=return$RecvStateNextprocessCertificateVerifyprocessClientKeyExchangep=unexpected(showp)(Just"client key exchange")processCertificateVerify(Handshake[CertVerify_])=return$RecvStateNextexpectChangeCipherprocessCertificateVerifyp=expectChangeCipherpexpectChangeCipherChangeCipherSpec=return$RecvStateHandshakeexpectFinishexpectChangeCipherp=unexpected(showp)(Just"change cipher")expectFinish(Finished_)=returnRecvStateDoneexpectFinishp=unexpected(showp)(Just"Handshake Finished")---makeServerHellosession=dosrand<-getStateRNGctx32>>=return.ServerRandomcaseprivKeysof(Justprivkey:_)->usingState_ctx$setPrivateKeyprivkey_->return()-- return a sensible error-- in TLS12, we need to check as well the certificates we are sending if they have in the extension-- the necessary bits set.secReneg<-usingState_ctxgetSecureRenegotiationextensions<-ifsecRenegthendovf<-usingState_ctx$docvf<-getVerifiedDataTruesvf<-getVerifiedDataFalsereturn$encodeExtSecureRenegotiationcvf(Justsvf)return[(0xff01,vf)]elsereturn[]usingState_ctx(setVersionver>>setServerRandomsrand)return$ServerHelloversrandsession(cipherIDusedCipher)(compressionIDusedCompression)extensionshandshakeSendServerData=doserverSession<-newSessionctxusingState_ctx(setSessionserverSessionFalse)serverhello<-makeServerHelloserverSession-- send ServerHello & Certificate & ServerKeyXchg & CertReqsendPacketctx$Handshake[serverhello,CertificatessrvCerts]whenneedKeyXchg$doletskg=SKX_RSANothingsendPacketctx(Handshake[ServerKeyXchgskg])-- FIXME we don't do this on a Anonymous serverwhen(pWantClientCertparams)$doletcertTypes=[CertificateType_RSA_Sign]letcreq=CertRequestcertTypesNothing[0,0,0]sendPacketctx(Handshake[creq])-- Send HelloDonesendPacketctx(Handshake[ServerHelloDone])handshakeServerWith__=fail"unexpected handshake type received. expecting client hello"-- after receiving a client hello, we need to redo a handshakehandshakeServer::MonadIOm=>TLSCtxc->m()handshakeServerctx=dohss<-recvPacketHandshakectxcasehssof[ch]->handshakeServerWithctxch_->fail("unexpected handshake received, excepting client hello and received "++showhss)-- | Handshake for a new TLS connection-- This is to be called at the beginning of a connection, and during renegotiationhandshake::MonadIOm=>TLSCtxc->m()handshakectx=docc<-usingState_ctx(stClientContext<$>get)liftIO$handleException$ifccthenhandshakeClientctxelsehandshakeServerctxwherehandleExceptionf=catchf$\exception->dolettlserror=maybe(Error_Misc$showexception)id$fromExceptionexceptionsetEstablishedctxFalsesendPacketctx(errorToAlerttlserror)handshakeFailedtlserror-- | sendData sends a bunch of data.-- It will automatically chunk data to acceptable packet sizesendData::MonadIOm=>TLSCtxc->L.ByteString->m()sendDatactxdataToSend=checkValidctx>>mapM_sendDataChunk(L.toChunksdataToSend)wheresendDataChunkd|B.lengthd>16384=dolet(sending,remain)=B.splitAt16384dsendPacketctx$AppDatasendingsendDataChunkremain|otherwise=sendPacketctx$AppDatad-- | recvData get data out of Data packet, and automatically renegotiate if-- a Handshake ClientHello is receivedrecvData::MonadIOm=>TLSCtxc->mB.ByteStringrecvDatactx=docheckValidctxpkt<-recvPacketctxcasepktof-- on server context receiving a client hello == renegotiationRight(Handshake[ch@(ClientHello______)])->handshakeServerWithctxch>>recvDatactx-- on client context, receiving a hello request == renegotiationRight(Handshake[HelloRequest])->handshakeClientctx>>recvDatactxRight(Alert[(AlertLevel_Fatal,_)])->dosetEOFctxreturnB.emptyRight(Alert[(AlertLevel_Warning,CloseNotify)])->dosetEOFctxreturnB.emptyRight(AppDatax)->returnxRightp->error("error unexpected packet: "++showp)Lefterr->error("error received: "++showerr)recvData'::MonadIOm=>TLSCtxc->mL.ByteStringrecvData'ctx=recvDatactx>>=return.L.fromChunks.(:[])