{-# LANGUAGE RecordWildCards #-}
module Network.QUIC.Packet.Encode (
encodeVersionNegotiationPacket
, encodeRetryPacket
, encodePlainPacket
) where
import qualified Data.ByteString as BS
import Foreign.ForeignPtr
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
encodeVersionNegotiationPacket :: VersionNegotiationPacket -> IO ByteString
encodeVersionNegotiationPacket :: VersionNegotiationPacket -> IO ByteString
encodeVersionNegotiationPacket (VersionNegotiationPacket CID
dCID CID
sCID [Version]
vers) = Int -> (WriteBuffer -> IO ()) -> IO ByteString
withWriteBuffer Int
maximumQUICHeaderSize forall a b. (a -> b) -> a -> b
$ \WriteBuffer
wbuf -> do
Flags Word8
flags <- IO (Flags Raw)
versionNegotiationPacketType
WriteBuffer -> Word8 -> IO ()
write8 WriteBuffer
wbuf Word8
flags
WriteBuffer -> Version -> CID -> CID -> IO ()
encodeLongHeader WriteBuffer
wbuf Version
Negotiation CID
dCID CID
sCID
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(Version Word32
ver) -> WriteBuffer -> Word32 -> IO ()
write32 WriteBuffer
wbuf Word32
ver) [Version]
vers
encodeRetryPacket :: RetryPacket -> IO ByteString
encodeRetryPacket :: RetryPacket -> IO ByteString
encodeRetryPacket (RetryPacket Version
ver CID
dCID CID
sCID ByteString
token (Left CID
odCID)) = Int -> (WriteBuffer -> IO ()) -> IO ByteString
withWriteBuffer Int
maximumQUICHeaderSize forall a b. (a -> b) -> a -> b
$ \WriteBuffer
wbuf -> do
forall a. Readable a => a -> IO ()
save WriteBuffer
wbuf
Flags Word8
flags <- Version -> IO (Flags Raw)
retryPacketType Version
ver
WriteBuffer -> Word8 -> IO ()
write8 WriteBuffer
wbuf Word8
flags
WriteBuffer -> Version -> CID -> CID -> IO ()
encodeLongHeader WriteBuffer
wbuf Version
ver CID
dCID CID
sCID
WriteBuffer -> ByteString -> IO ()
copyByteString WriteBuffer
wbuf ByteString
token
Int
siz <- forall a. Readable a => a -> IO Int
savingSize WriteBuffer
wbuf
ByteString
pseudo0 <- forall a. Readable a => a -> Int -> IO ByteString
extractByteString WriteBuffer
wbuf forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a
negate Int
siz
let tag :: ByteString
tag = Version -> CID -> ByteString -> ByteString
calculateIntegrityTag Version
ver CID
odCID ByteString
pseudo0
WriteBuffer -> ByteString -> IO ()
copyByteString WriteBuffer
wbuf ByteString
tag
encodeRetryPacket (RetryPacket Version
ver CID
dCID CID
sCID ByteString
token (Right (ByteString
_,ByteString
tag))) = Int -> (WriteBuffer -> IO ()) -> IO ByteString
withWriteBuffer Int
maximumQUICHeaderSize forall a b. (a -> b) -> a -> b
$ \WriteBuffer
wbuf -> do
forall a. Readable a => a -> IO ()
save WriteBuffer
wbuf
Flags Word8
flags <- Version -> IO (Flags Raw)
retryPacketType Version
ver
WriteBuffer -> Word8 -> IO ()
write8 WriteBuffer
wbuf Word8
flags
WriteBuffer -> Version -> CID -> CID -> IO ()
encodeLongHeader WriteBuffer
wbuf Version
ver CID
dCID CID
sCID
WriteBuffer -> ByteString -> IO ()
copyByteString WriteBuffer
wbuf ByteString
token
WriteBuffer -> ByteString -> IO ()
copyByteString WriteBuffer
wbuf ByteString
tag
encodePlainPacket :: Connection -> SizedBuffer -> PlainPacket -> Maybe Int -> IO (Int,Int)
encodePlainPacket :: Connection
-> SizedBuffer -> PlainPacket -> Maybe Int -> IO (Int, Int)
encodePlainPacket Connection
conn (SizedBuffer Buffer
buf Int
bufsiz) ppkt :: PlainPacket
ppkt@(PlainPacket Header
_ Plain
plain) Maybe Int
mlen = do
let mlen' :: Maybe Int
mlen' | Int -> Bool
isNoPaddings (Plain -> Int
plainMarks Plain
plain) = forall a. Maybe a
Nothing
| Bool
otherwise = Maybe Int
mlen
WriteBuffer
wbuf <- Buffer -> Int -> IO WriteBuffer
newWriteBuffer Buffer
buf Int
bufsiz
Connection
-> WriteBuffer -> PlainPacket -> Maybe Int -> IO (Int, Int)
encodePlainPacket' Connection
conn WriteBuffer
wbuf PlainPacket
ppkt Maybe Int
mlen'
encodePlainPacket' :: Connection -> WriteBuffer -> PlainPacket -> Maybe Int -> IO (Int,Int)
encodePlainPacket' :: Connection
-> WriteBuffer -> PlainPacket -> Maybe Int -> IO (Int, Int)
encodePlainPacket' Connection
conn WriteBuffer
wbuf (PlainPacket (Initial Version
ver CID
dCID CID
sCID ByteString
token) (Plain Flags Raw
flags Int
pn [Frame]
frames Int
_)) Maybe Int
mlen = do
Buffer
headerBeg <- WriteBuffer -> IO Buffer
currentOffset WriteBuffer
wbuf
(Word32
epn, Int
epnLen) <- Connection
-> WriteBuffer
-> LongHeaderPacketType
-> Version
-> CID
-> CID
-> Flags Raw
-> Int
-> IO (Word32, Int)
encodeLongHeaderPP Connection
conn WriteBuffer
wbuf LongHeaderPacketType
InitialPacketType Version
ver CID
dCID CID
sCID Flags Raw
flags Int
pn
WriteBuffer -> Int64 -> IO ()
encodeInt' WriteBuffer
wbuf forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
token
WriteBuffer -> ByteString -> IO ()
copyByteString WriteBuffer
wbuf ByteString
token
Connection
-> WriteBuffer
-> [Frame]
-> Int
-> Word32
-> Int
-> Buffer
-> Maybe Int
-> EncryptionLevel
-> Bool
-> IO (Int, Int)
protectPayloadHeader Connection
conn WriteBuffer
wbuf [Frame]
frames Int
pn Word32
epn Int
epnLen Buffer
headerBeg Maybe Int
mlen EncryptionLevel
InitialLevel Bool
False
encodePlainPacket' Connection
conn WriteBuffer
wbuf (PlainPacket (RTT0 Version
ver CID
dCID CID
sCID) (Plain Flags Raw
flags Int
pn [Frame]
frames Int
_)) Maybe Int
mlen = do
Buffer
headerBeg <- WriteBuffer -> IO Buffer
currentOffset WriteBuffer
wbuf
(Word32
epn, Int
epnLen) <- Connection
-> WriteBuffer
-> LongHeaderPacketType
-> Version
-> CID
-> CID
-> Flags Raw
-> Int
-> IO (Word32, Int)
encodeLongHeaderPP Connection
conn WriteBuffer
wbuf LongHeaderPacketType
RTT0PacketType Version
ver CID
dCID CID
sCID Flags Raw
flags Int
pn
Connection
-> WriteBuffer
-> [Frame]
-> Int
-> Word32
-> Int
-> Buffer
-> Maybe Int
-> EncryptionLevel
-> Bool
-> IO (Int, Int)
protectPayloadHeader Connection
conn WriteBuffer
wbuf [Frame]
frames Int
pn Word32
epn Int
epnLen Buffer
headerBeg Maybe Int
mlen EncryptionLevel
RTT0Level Bool
False
encodePlainPacket' Connection
conn WriteBuffer
wbuf (PlainPacket (Handshake Version
ver CID
dCID CID
sCID) (Plain Flags Raw
flags Int
pn [Frame]
frames Int
_)) Maybe Int
mlen = do
Buffer
headerBeg <- WriteBuffer -> IO Buffer
currentOffset WriteBuffer
wbuf
(Word32
epn, Int
epnLen) <- Connection
-> WriteBuffer
-> LongHeaderPacketType
-> Version
-> CID
-> CID
-> Flags Raw
-> Int
-> IO (Word32, Int)
encodeLongHeaderPP Connection
conn WriteBuffer
wbuf LongHeaderPacketType
HandshakePacketType Version
ver CID
dCID CID
sCID Flags Raw
flags Int
pn
Connection
-> WriteBuffer
-> [Frame]
-> Int
-> Word32
-> Int
-> Buffer
-> Maybe Int
-> EncryptionLevel
-> Bool
-> IO (Int, Int)
protectPayloadHeader Connection
conn WriteBuffer
wbuf [Frame]
frames Int
pn Word32
epn Int
epnLen Buffer
headerBeg Maybe Int
mlen EncryptionLevel
HandshakeLevel Bool
False
encodePlainPacket' Connection
conn WriteBuffer
wbuf (PlainPacket (Short CID
dCID) (Plain Flags Raw
flags Int
pn [Frame]
frames Int
marks)) Maybe Int
mlen = do
Buffer
headerBeg <- WriteBuffer -> IO Buffer
currentOffset WriteBuffer
wbuf
let (Word32
epn, Int
epnLen) | Int -> Bool
is4bytesPN Int
marks = (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
pn, Int
4)
| Bool
otherwise = Int -> Int -> (Word32, Int)
encodePacketNumber Int
0 Int
pn
pp :: Flags Raw
pp = Int -> Flags Raw
encodePktNumLength Int
epnLen
Bool
quicBit <- Parameters -> Bool
greaseQuicBit forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO Parameters
getPeerParameters Connection
conn
(Bool
keyPhase,Int
_) <- Connection -> IO (Bool, Int)
getCurrentKeyPhase Connection
conn
Flags Word8
flags' <- Flags Raw -> Flags Raw -> Bool -> Bool -> IO (Flags Raw)
encodeShortHeaderFlags Flags Raw
flags Flags Raw
pp Bool
quicBit Bool
keyPhase
WriteBuffer -> Word8 -> IO ()
write8 WriteBuffer
wbuf Word8
flags'
let (ShortByteString
dcid, Word8
_) = CID -> (ShortByteString, Word8)
unpackCID CID
dCID
WriteBuffer -> ShortByteString -> IO ()
copyShortByteString WriteBuffer
wbuf ShortByteString
dcid
Connection
-> WriteBuffer
-> [Frame]
-> Int
-> Word32
-> Int
-> Buffer
-> Maybe Int
-> EncryptionLevel
-> Bool
-> IO (Int, Int)
protectPayloadHeader Connection
conn WriteBuffer
wbuf [Frame]
frames Int
pn Word32
epn Int
epnLen Buffer
headerBeg Maybe Int
mlen EncryptionLevel
RTT1Level Bool
keyPhase
encodeLongHeader :: WriteBuffer
-> Version -> CID -> CID
-> IO ()
WriteBuffer
wbuf (Version Word32
ver) CID
dCID CID
sCID = do
WriteBuffer -> Word32 -> IO ()
write32 WriteBuffer
wbuf Word32
ver
let (ShortByteString
dcid, Word8
dcidlen) = CID -> (ShortByteString, Word8)
unpackCID CID
dCID
WriteBuffer -> Word8 -> IO ()
write8 WriteBuffer
wbuf Word8
dcidlen
WriteBuffer -> ShortByteString -> IO ()
copyShortByteString WriteBuffer
wbuf ShortByteString
dcid
let (ShortByteString
scid, Word8
scidlen) = CID -> (ShortByteString, Word8)
unpackCID CID
sCID
WriteBuffer -> Word8 -> IO ()
write8 WriteBuffer
wbuf Word8
scidlen
WriteBuffer -> ShortByteString -> IO ()
copyShortByteString WriteBuffer
wbuf ShortByteString
scid
encodeLongHeaderPP :: Connection -> WriteBuffer
-> LongHeaderPacketType -> Version -> CID -> CID
-> Flags Raw
-> PacketNumber
-> IO (EncodedPacketNumber, Int)
Connection
conn WriteBuffer
wbuf LongHeaderPacketType
pkttyp Version
ver CID
dCID CID
sCID Flags Raw
flags Int
pn = do
let el :: (Word32, Int)
el@(Word32
_, Int
pnLen) = Int -> Int -> (Word32, Int)
encodePacketNumber Int
0 Int
pn
pp :: Flags Raw
pp = Int -> Flags Raw
encodePktNumLength Int
pnLen
Bool
quicBit <- Parameters -> Bool
greaseQuicBit forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO Parameters
getPeerParameters Connection
conn
Flags Word8
flags' <- Version
-> LongHeaderPacketType
-> Flags Raw
-> Flags Raw
-> Bool
-> IO (Flags Raw)
encodeLongHeaderFlags Version
ver LongHeaderPacketType
pkttyp Flags Raw
flags Flags Raw
pp Bool
quicBit
WriteBuffer -> Word8 -> IO ()
write8 WriteBuffer
wbuf Word8
flags'
WriteBuffer -> Version -> CID -> CID -> IO ()
encodeLongHeader WriteBuffer
wbuf Version
ver CID
dCID CID
sCID
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32, Int)
el
protectPayloadHeader :: Connection -> WriteBuffer -> [Frame] -> PacketNumber -> EncodedPacketNumber -> Int -> Buffer -> Maybe Int -> EncryptionLevel -> Bool -> IO (Int,Int)
Connection
conn WriteBuffer
wbuf [Frame]
frames Int
pn Word32
epn Int
epnLen Buffer
headerBeg Maybe Int
mlen EncryptionLevel
lvl Bool
keyPhase = do
let encBuf :: Buffer
encBuf = Connection -> Buffer
encodeBuf Connection
conn
encBufLen :: Int
encBufLen = Int
1500 forall a. Num a => a -> a -> a
- Int
20 forall a. Num a => a -> a -> a
- Int
8
Int
payloadWithoutPaddingSiz <- Buffer -> Int -> [Frame] -> IO Int
encodeFramesWithPadding Buffer
encBuf Int
encBufLen [Frame]
frames
Cipher
cipher <- Connection -> EncryptionLevel -> IO Cipher
getCipher Connection
conn EncryptionLevel
lvl
Buffer
lengthOrPNBeg <- WriteBuffer -> IO Buffer
currentOffset WriteBuffer
wbuf
(Int
packetLen, Int
headerLen, Int
plainLen, Int
tagLen, Int
padLen)
<- forall {m :: * -> *} {a}.
Monad m =>
Cipher -> Ptr a -> Int -> m (Int, Int, Int, Int, Int)
calcLen Cipher
cipher Buffer
lengthOrPNBeg Int
payloadWithoutPaddingSiz
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EncryptionLevel
lvl forall a. Eq a => a -> a -> Bool
/= EncryptionLevel
RTT1Level) forall a b. (a -> b) -> a -> b
$ forall {a}. Integral a => a -> IO ()
writeLen (Int
epnLen forall a. Num a => a -> a -> a
+ Int
plainLen forall a. Num a => a -> a -> a
+ Int
tagLen)
Buffer
pnBeg <- WriteBuffer -> IO Buffer
currentOffset WriteBuffer
wbuf
forall {a}. (Eq a, Num a) => a -> IO ()
writeEpn Int
epnLen
Buffer
cryptoBeg <- WriteBuffer -> IO Buffer
currentOffset WriteBuffer
wbuf
ByteString
plaintext <- Buffer -> Int -> IO ByteString
mkBS Buffer
encBuf Int
plainLen
ByteString
header <- Buffer -> Int -> IO ByteString
mkBS Buffer
headerBeg Int
headerLen
let sampleBeg :: Ptr b
sampleBeg = Buffer
pnBeg forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
4
Coder
coder <- Connection -> EncryptionLevel -> Bool -> IO Coder
getCoder Connection
conn EncryptionLevel
lvl Bool
keyPhase
Protector
protector <- Connection -> EncryptionLevel -> IO Protector
getProtector Connection
conn EncryptionLevel
lvl
Protector -> Buffer -> IO ()
setSample Protector
protector forall {b}. Ptr b
sampleBeg
Int
len <- Coder -> Buffer -> ByteString -> AssDat -> Int -> IO Int
encrypt Coder
coder Buffer
cryptoBeg ByteString
plaintext (ByteString -> AssDat
AssDat ByteString
header) Int
pn
Buffer
maskBeg <- Protector -> IO Buffer
getMask Protector
protector
if Int
len forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Buffer
maskBeg forall a. Eq a => a -> a -> Bool
== forall {b}. Ptr b
nullPtr then
forall (m :: * -> *) a. Monad m => a -> m a
return (-Int
1, -Int
1)
else do
Buffer -> Buffer -> Int -> Buffer -> IO ()
protectHeader Buffer
headerBeg Buffer
pnBeg Int
epnLen Buffer
maskBeg
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
packetLen, Int
padLen)
where
calcLen :: Cipher -> Ptr a -> Int -> m (Int, Int, Int, Int, Int)
calcLen Cipher
cipher Ptr a
lengthOrPNBeg Int
payloadWithoutPaddingSiz = do
let headerLen :: Int
headerLen = (Ptr a
lengthOrPNBeg forall a b. Ptr a -> Ptr b -> Int
`minusPtr` Buffer
headerBeg)
forall a. Num a => a -> a -> a
+ (if EncryptionLevel
lvl forall a. Eq a => a -> a -> Bool
/= EncryptionLevel
RTT1Level then Int
2 else Int
0)
forall a. Num a => a -> a -> a
+ Int
epnLen
let tagLen :: Int
tagLen = Cipher -> Int
tagLength Cipher
cipher
plainLen :: Int
plainLen = case Maybe Int
mlen of
Maybe Int
Nothing -> Int
payloadWithoutPaddingSiz
Just Int
expectedLen -> Int
expectedLen forall a. Num a => a -> a -> a
- Int
headerLen forall a. Num a => a -> a -> a
- Int
tagLen
packetLen :: Int
packetLen = Int
headerLen forall a. Num a => a -> a -> a
+ Int
plainLen forall a. Num a => a -> a -> a
+ Int
tagLen
padLen :: Int
padLen = Int
plainLen forall a. Num a => a -> a -> a
- Int
payloadWithoutPaddingSiz
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
packetLen, Int
headerLen, Int
plainLen, Int
tagLen, Int
padLen)
writeLen :: a -> IO ()
writeLen a
len = WriteBuffer -> Int64 -> IO ()
encodeInt'2 WriteBuffer
wbuf forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral a
len
writeEpn :: a -> IO ()
writeEpn a
1 = WriteBuffer -> Word8 -> IO ()
write8 WriteBuffer
wbuf forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
epn
writeEpn a
2 = WriteBuffer -> Word16 -> IO ()
write16 WriteBuffer
wbuf forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
epn
writeEpn a
3 = WriteBuffer -> Word32 -> IO ()
write24 WriteBuffer
wbuf Word32
epn
writeEpn a
_ = WriteBuffer -> Word32 -> IO ()
write32 WriteBuffer
wbuf Word32
epn
protectHeader :: Buffer -> Buffer -> Int -> Buffer -> IO ()
Buffer
headerBeg Buffer
pnBeg Int
epnLen Buffer
maskBeg = do
IO ()
shuffleFlag
Int -> IO ()
shufflePN Int
0
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
epnLen forall a. Ord a => a -> a -> Bool
>= Int
2) forall a b. (a -> b) -> a -> b
$ Int -> IO ()
shufflePN Int
1
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
epnLen forall a. Ord a => a -> a -> Bool
>= Int
3) forall a b. (a -> b) -> a -> b
$ Int -> IO ()
shufflePN Int
2
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
epnLen forall a. Eq a => a -> a -> Bool
== Int
4) forall a b. (a -> b) -> a -> b
$ Int -> IO ()
shufflePN Int
3
where
mask :: Int -> IO a
mask Int
n = forall a. Storable a => Ptr a -> IO a
peek (Buffer
maskBeg forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
n)
shuffleFlag :: IO ()
shuffleFlag = do
Flags Raw
flags <- forall a. Word8 -> Flags a
Flags forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Buffer -> Int -> IO Word8
peek8 Buffer
headerBeg Int
0
Word8
mask0 <- forall {a}. Storable a => Int -> IO a
mask Int
0
let Flags Word8
proFlags = Flags Raw -> Word8 -> Flags Protected
protectFlags Flags Raw
flags Word8
mask0
Word8 -> Buffer -> Int -> IO ()
poke8 Word8
proFlags Buffer
headerBeg Int
0
shufflePN :: Int -> IO ()
shufflePN Int
n = do
Word8
p0 <- Buffer -> Int -> IO Word8
peek8 Buffer
pnBeg Int
n
Word8
maskn1 <- forall {a}. Storable a => Int -> IO a
mask (Int
n forall a. Num a => a -> a -> a
+ Int
1)
let pp0 :: Word8
pp0 = Word8
p0 forall a. Bits a => a -> a -> a
`xor` Word8
maskn1
Word8 -> Buffer -> Int -> IO ()
poke8 Word8
pp0 Buffer
pnBeg Int
n
mkBS :: Buffer -> Int -> IO ByteString
mkBS :: Buffer -> Int -> IO ByteString
mkBS Buffer
ptr Int
siz = do
ForeignPtr Word8
fptr <- forall a. Ptr a -> IO (ForeignPtr a)
newForeignPtr_ Buffer
ptr
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ForeignPtr Word8 -> Int -> Int -> ByteString
PS ForeignPtr Word8
fptr Int
0 Int
siz