quic-0.0.0: Network/QUIC/Packet/Encode.hs
module Network.QUIC.Packet.Encode (
-- encodePacket
encodeVersionNegotiationPacket
, encodeRetryPacket
, encodePlainPacket
) where
import qualified Data.ByteString as BS
import Foreign.Ptr
import Foreign.Storable (peek)
import Network.QUIC.Connection
import Network.QUIC.Crypto
import Network.QUIC.Imports
import Network.QUIC.Packet.Frame
import Network.QUIC.Packet.Header
import Network.QUIC.Packet.Number
import Network.QUIC.Parameters
import Network.QUIC.Types
----------------------------------------------------------------
-- | This is not used internally.
{-
encodePacket :: Connection -> PacketO -> IO [ByteString]
encodePacket _ (PacketOV pkt) = (:[]) <$> encodeVersionNegotiationPacket pkt
encodePacket _ (PacketOR pkt) = (:[]) <$> encodeRetryPacket pkt
encodePacket conn (PacketOP pkt) = fst <$> encodePlainPacket conn pkt Nothing
-}
----------------------------------------------------------------
encodeVersionNegotiationPacket :: VersionNegotiationPacket -> IO ByteString
encodeVersionNegotiationPacket (VersionNegotiationPacket dCID sCID vers) = withWriteBuffer maximumQUICHeaderSize $ \wbuf -> do
Flags flags <- versionNegotiationPacketType
write8 wbuf flags
-- ver .. sCID
encodeLongHeader wbuf Negotiation dCID sCID
-- vers
mapM_ (\(Version ver) -> write32 wbuf ver) vers
-- no header protection
----------------------------------------------------------------
encodeRetryPacket :: RetryPacket -> IO ByteString
encodeRetryPacket (RetryPacket ver dCID sCID token (Left odCID)) = withWriteBuffer maximumQUICHeaderSize $ \wbuf -> do
save wbuf
Flags flags <- retryPacketType
write8 wbuf flags
encodeLongHeader wbuf ver dCID sCID
copyByteString wbuf token
siz <- savingSize wbuf
pseudo0 <- extractByteString wbuf $ negate siz
let tag = calculateIntegrityTag ver odCID pseudo0
copyByteString wbuf tag
-- no header protection
encodeRetryPacket _ = error "encodeRetryPacket"
----------------------------------------------------------------
encodePlainPacket :: Connection -> Buffer -> BufferSize -> PlainPacket -> Maybe Int -> IO (Int,Int)
encodePlainPacket conn buf bufsiz ppkt@(PlainPacket _ plain) mlen = do
let mlen' | isNoPaddings (plainMarks plain) = Nothing
| otherwise = mlen
wbuf <- newWriteBuffer buf bufsiz
let encodeBuf = buf `plusPtr` bufsiz -- see sender
encodePlainPacket' conn wbuf encodeBuf ppkt mlen'
encodePlainPacket' :: Connection -> WriteBuffer -> Buffer -> PlainPacket -> Maybe Int -> IO (Int,Int)
encodePlainPacket' conn wbuf encodeBuf (PlainPacket (Initial ver dCID sCID token) (Plain flags pn frames _)) mlen = do
headerBeg <- currentOffset wbuf
-- flag ... sCID
(epn, epnLen) <- encodeLongHeaderPP conn wbuf InitialPacketType ver dCID sCID flags pn
-- token
encodeInt' wbuf $ fromIntegral $ BS.length token
copyByteString wbuf token
-- length .. payload
protectPayloadHeader conn wbuf encodeBuf frames pn epn epnLen headerBeg mlen InitialLevel False
encodePlainPacket' conn wbuf encodeBuf (PlainPacket (RTT0 ver dCID sCID) (Plain flags pn frames _)) mlen = do
headerBeg <- currentOffset wbuf
-- flag ... sCID
(epn, epnLen) <- encodeLongHeaderPP conn wbuf RTT0PacketType ver dCID sCID flags pn
-- length .. payload
protectPayloadHeader conn wbuf encodeBuf frames pn epn epnLen headerBeg mlen RTT0Level False
encodePlainPacket' conn wbuf encodeBuf (PlainPacket (Handshake ver dCID sCID) (Plain flags pn frames _)) mlen = do
headerBeg <- currentOffset wbuf
-- flag ... sCID
(epn, epnLen) <- encodeLongHeaderPP conn wbuf HandshakePacketType ver dCID sCID flags pn
-- length .. payload
protectPayloadHeader conn wbuf encodeBuf frames pn epn epnLen headerBeg mlen HandshakeLevel False
encodePlainPacket' conn wbuf encodeBuf (PlainPacket (Short dCID) (Plain flags pn frames marks)) mlen = do
headerBeg <- currentOffset wbuf
-- flag
let (epn, epnLen) | is4bytesPN marks = (fromIntegral pn, 4)
| otherwise = encodePacketNumber 0 {- dummy -} pn
pp = encodePktNumLength epnLen
quicBit <- greaseQuicBit <$> getPeerParameters conn
(keyPhase,_) <- getCurrentKeyPhase conn
Flags flags' <- encodeShortHeaderFlags flags pp quicBit keyPhase
write8 wbuf flags'
-- dCID
let (dcid, _) = unpackCID dCID
copyShortByteString wbuf dcid
protectPayloadHeader conn wbuf encodeBuf frames pn epn epnLen headerBeg mlen RTT1Level keyPhase
----------------------------------------------------------------
encodeLongHeader :: WriteBuffer
-> Version -> CID -> CID
-> IO ()
encodeLongHeader wbuf (Version ver) dCID sCID = do
write32 wbuf ver
let (dcid, dcidlen) = unpackCID dCID
write8 wbuf dcidlen
copyShortByteString wbuf dcid
let (scid, scidlen) = unpackCID sCID
write8 wbuf scidlen
copyShortByteString wbuf scid
----------------------------------------------------------------
encodeLongHeaderPP :: Connection -> WriteBuffer
-> LongHeaderPacketType -> Version -> CID -> CID
-> Flags Raw
-> PacketNumber
-> IO (EncodedPacketNumber, Int)
encodeLongHeaderPP conn wbuf pkttyp ver dCID sCID flags pn = do
let el@(_, pnLen) = encodePacketNumber 0 {- dummy -} pn
pp = encodePktNumLength pnLen
quicBit <- greaseQuicBit <$> getPeerParameters conn
Flags flags' <- encodeLongHeaderFlags pkttyp flags pp quicBit
write8 wbuf flags'
encodeLongHeader wbuf ver dCID sCID
return el
----------------------------------------------------------------
protectPayloadHeader :: Connection -> WriteBuffer -> Buffer -> [Frame] -> PacketNumber -> EncodedPacketNumber -> Int -> Buffer -> Maybe Int -> EncryptionLevel -> Bool -> IO (Int,Int)
protectPayloadHeader conn wbuf encodeBuf frames pn epn epnLen headerBeg mlen lvl keyPhase = do
-- Real size is maximumUdpPayloadSize. But smaller is better.
let encodeBufLen = 1500 - 20 - 8
payloadWithoutPaddingSiz <- encodeFramesWithPadding encodeBuf encodeBufLen frames
cipher <- getCipher conn lvl
coder <- getCoder conn lvl keyPhase
protector <- getProtector conn lvl
-- before length or packer number
lengthOrPNBeg <- currentOffset wbuf
(packetLen, headerLen, plainLen, tagLen, padLen)
<- calcLen cipher lengthOrPNBeg payloadWithoutPaddingSiz
when (lvl /= RTT1Level) $ writeLen (epnLen + plainLen + tagLen)
pnBeg <- currentOffset wbuf
writeEpn epnLen
-- payload
cryptoBeg <- currentOffset wbuf
let sampleBeg = pnBeg `plusPtr` 4
setSample protector sampleBeg
len <- encrypt coder encodeBuf plainLen headerBeg headerLen pn cryptoBeg
if len < 0 then
return (-1, -1)
else do
-- protecting header
maskBeg <- getMask protector
if maskBeg == nullPtr then
return (-1, -1)
else do
protectHeader headerBeg pnBeg epnLen maskBeg
return (packetLen, padLen)
where
calcLen cipher lengthOrPNBeg payloadWithoutPaddingSiz = do
let headerLen = (lengthOrPNBeg `minusPtr` headerBeg)
-- length: assuming 2byte length
+ (if lvl /= RTT1Level then 2 else 0)
+ epnLen
let tagLen = tagLength cipher
plainLen = case mlen of
Nothing -> payloadWithoutPaddingSiz
Just expectedLen -> expectedLen - headerLen - tagLen
packetLen = headerLen + plainLen + tagLen
padLen = plainLen - payloadWithoutPaddingSiz
return (packetLen, headerLen, plainLen, tagLen, padLen)
-- length: assuming 2byte length
writeLen len = encodeInt'2 wbuf $ fromIntegral len
writeEpn 1 = write8 wbuf $ fromIntegral epn
writeEpn 2 = write16 wbuf $ fromIntegral epn
writeEpn 3 = write24 wbuf epn
writeEpn _ = write32 wbuf epn
----------------------------------------------------------------
protectHeader :: Buffer -> Buffer -> Int -> Buffer -> IO ()
protectHeader headerBeg pnBeg epnLen maskBeg = do
shuffleFlag
shufflePN 0
when (epnLen >= 2) $ shufflePN 1
when (epnLen >= 3) $ shufflePN 2
when (epnLen == 4) $ shufflePN 3
where
mask n = peek (maskBeg `plusPtr` n)
shuffleFlag = do
flags <- Flags <$> peek8 headerBeg 0
mask0 <- mask 0
let Flags proFlags = protectFlags flags mask0
poke8 proFlags headerBeg 0
shufflePN n = do
p0 <- peek8 pnBeg n
maskn1 <- mask (n + 1)
let pp0 = p0 `xor` maskn1
poke8 pp0 pnBeg n