http2-1.3.1/0000755000000000000000000000000012624764141010752 5ustar0000000000000000http2-1.3.1/ChangeLog.md0000644000000000000000000000045312624764141013125 0ustar0000000000000000## 1.3.1 * Defining IllegalTableSizeUpdate. ## 1.3.0 * APIs `Network.HTTP2.Priority` are changed again. `Precedence` is introduced. ## 1.2.0 * APIs of `Network.HTTP2.Priority` are changed. `delete` is provided. Internal data structure is changed from random skew heap to priority search queue. http2-1.3.1/http2.cabal0000644000000000000000000002105712624764141013004 0ustar0000000000000000Name: http2 Version: 1.3.1 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 License-File: LICENSE Synopsis: HTTP/2.0 library including frames and HPACK Description: HTTP/2.0 library including frames and HPACK. Category: Network Cabal-Version: >= 1.10 Build-Type: Simple Extra-Source-Files: ChangeLog.md ---------------------------------------------------------------- Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/http2 Flag devel Description: Development commands Default: False ---------------------------------------------------------------- Library Default-Language: Haskell2010 GHC-Options: -Wall Exposed-Modules: Network.HPACK Network.HTTP2 Network.HTTP2.Priority Other-Modules: Network.HPACK.Builder Network.HPACK.Builder.Word8 Network.HPACK.Huffman Network.HPACK.Huffman.Bit Network.HPACK.Huffman.ByteString Network.HPACK.Huffman.Decode Network.HPACK.Huffman.Encode Network.HPACK.Huffman.Params Network.HPACK.Huffman.Table Network.HPACK.Huffman.Tree Network.HPACK.HeaderBlock Network.HPACK.HeaderBlock.Decode Network.HPACK.HeaderBlock.Encode Network.HPACK.HeaderBlock.From Network.HPACK.HeaderBlock.HeaderField Network.HPACK.HeaderBlock.Integer Network.HPACK.HeaderBlock.String Network.HPACK.HeaderBlock.To Network.HPACK.Table Network.HPACK.Table.DoubleHashMap Network.HPACK.Table.Dynamic Network.HPACK.Table.Entry Network.HPACK.Table.Static Network.HPACK.Types Network.HTTP2.Decode Network.HTTP2.Encode Network.HTTP2.Priority.PSQ Network.HTTP2.Priority.Queue Network.HTTP2.Types Build-Depends: base >= 4.6 && < 5 , array , bytestring >= 0.10 , bytestring-builder , containers >= 0.5 , psqueues , stm , unordered-containers ---------------------------------------------------------------- Test-Suite doctest Type: exitcode-stdio-1.0 Default-Language: Haskell2010 HS-Source-Dirs: test Ghc-Options: -Wall Main-Is: doctests.hs Build-Depends: base >= 4 && < 5 , doctest >= 0.9.3 Test-Suite spec Type: exitcode-stdio-1.0 Default-Language: Haskell2010 HS-Source-Dirs: test, . Ghc-Options: -Wall Main-Is: Spec.hs Other-Modules: HPACK.DecodeSpec HPACK.HeaderBlock HPACK.HeaderBlockSpec HPACK.HuffmanSpec HPACK.IntegerSpec HTTP2.FrameSpec HTTP2.PrioritySpec Build-Depends: base >= 4 && < 5 , array , bytestring , bytestring-builder , containers , hex , hspec >= 1.3 , mwc-random , psqueues , stm , unordered-containers , word8 Test-Suite hpack Type: exitcode-stdio-1.0 Default-Language: Haskell2010 HS-Source-Dirs: test-hpack, . Ghc-Options: -Wall Main-Is: Spec.hs Other-Modules: HPACKDecode HPACKSpec JSON Build-Depends: base >= 4 && < 5 , aeson , aeson-pretty , array , bytestring , bytestring-builder , containers , directory , filepath , hex , hspec >= 1.3 , text , unordered-containers , vector , word8 Test-Suite frame Type: exitcode-stdio-1.0 Default-Language: Haskell2010 HS-Source-Dirs: test-frame GHC-Options: -Wall Main-Is: Spec.hs Other-Modules: Case JSON Build-Depends: base >= 4 && < 5 , Glob , aeson , aeson-pretty , bytestring , directory , filepath , hex , hspec >= 1.3 , http2 , text , unordered-containers ---------------------------------------------------------------- Executable hpack-encode Default-Language: Haskell2010 HS-Source-Dirs: test-hpack, . GHC-Options: -Wall if flag(devel) Buildable: True else Buildable: False Main-Is: hpack-encode.hs Other-Modules: HPACKEncode Build-Depends: base >= 4 && < 5 , aeson , aeson-pretty , array , bytestring , bytestring-builder , containers , hex , text , unordered-containers , vector , word8 Executable hpack-debug Default-Language: Haskell2010 HS-Source-Dirs: test-hpack, . GHC-Options: -Wall if flag(devel) Buildable: True else Buildable: False Main-Is: hpack-debug.hs Build-Depends: base >= 4 && < 5 , aeson , array , bytestring , bytestring-builder , containers , hex , text , unordered-containers , vector , word8 Executable hpack-stat Default-Language: Haskell2010 HS-Source-Dirs: test-hpack, . GHC-Options: -Wall if flag(devel) Buildable: True else Buildable: False Main-Is: hpack-stat.hs Build-Depends: base >= 4 && < 5 , aeson , aeson-pretty , array , bytestring , bytestring-builder , containers , directory , filepath , text , unordered-containers , vector , word8 Executable frame-encode Default-Language: Haskell2010 HS-Source-Dirs: test-frame GHC-Options: -Wall if flag(devel) Buildable: True else Buildable: False Main-Is: frame-encode.hs Other-Modules: Case JSON Build-Depends: base >= 4 && < 5 , aeson , aeson-pretty , bytestring , hex , http2 , text , unordered-containers Benchmark criterion Type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: bench, . Ghc-Options: -Wall Main-Is: Main.hs Build-Depends: base , array , containers , criterion , hashtables , heaps , mwc-random , psqueues , random , stm http2-1.3.1/LICENSE0000644000000000000000000000276512624764141011771 0ustar0000000000000000Copyright (c) 2013, IIJ Innovation Institute Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holders nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. http2-1.3.1/Setup.hs0000644000000000000000000000005612624764141012407 0ustar0000000000000000import Distribution.Simple main = defaultMain http2-1.3.1/bench/0000755000000000000000000000000012624764141012031 5ustar0000000000000000http2-1.3.1/bench/Main.hs0000644000000000000000000001416312624764141013256 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module Main where import Control.Concurrent.STM import Criterion.Main import Data.List (foldl') import System.Random import qualified ArrayOfQueue as A import qualified ArrayOfQueueIO as AIO import qualified BinaryHeap as B import qualified BinaryHeapIO as BIO import qualified Heap as O import qualified Network.HTTP2.Priority.PSQ as P import qualified RandomSkewHeap as R type Key = Int type Weight = Int numOfStreams :: Int numOfStreams = 100 numOfTrials :: Int numOfTrials = 10000 main :: IO () main = do gen <- getStdGen let ks = [1,3..] ws = take numOfStreams $ randomRs (1,256) gen xs = zip ks ws defaultMain [ bgroup "enqueue & dequeue" [ bench "Random Skew Heap" $ whnf enqdeqR xs , bench "Okasaki Heap" $ whnf enqdeqO xs , bench "Priority Search Queue" $ whnf enqdeqP xs , bench "Binary Heap STM" $ nfIO (enqdeqB xs) , bench "Binary Heap IO" $ nfIO (enqdeqBIO xs) , bench "Array of Queue STM" $ nfIO (enqdeqA xs) , bench "Array of Queue IO" $ nfIO (enqdeqAIO xs) ] , bgroup "delete" [ bench "Random Skew Heap" $ whnf deleteR xs , bench "Okasaki Heap" $ whnf deleteO xs , bench "Priority Search Queue" $ whnf deleteP xs , bench "Binary Heap STM" $ nfIO (deleteB xs) , bench "Binary Heap IO" $ nfIO (deleteBIO xs) , bench "Array of Queue IO" $ nfIO (deleteAIO xs) ] ] ---------------------------------------------------------------- enqdeqR :: [(Key,Weight)] -> () enqdeqR xs = loop pq numOfTrials where !pq = createR xs R.empty loop _ 0 = () loop q !n = case R.dequeue q of Nothing -> error "enqdeqR" Just (k,w,x,q') -> let !q'' = R.enqueue k w x q' in loop q'' (n - 1) deleteR :: [(Key,Weight)] -> R.PriorityQueue Int deleteR xs = foldl' (\p k -> snd (R.delete k p)) pq ks where !pq = createR xs R.empty (ks,_) = unzip xs createR :: [(Key,Weight)] -> R.PriorityQueue Int -> R.PriorityQueue Int createR [] !q = q createR ((k,w):xs) !q = createR xs q' where !q' = R.enqueue k w k q ---------------------------------------------------------------- enqdeqO :: [(Key,Weight)] -> O.PriorityQueue Int enqdeqO xs = loop pq numOfTrials where !pq = createO xs O.empty loop !q 0 = q loop !q !n = case O.dequeue q of Nothing -> error "enqdeqO" Just (k,w,x,q') -> loop (O.enqueue k w x q') (n - 1) deleteO :: [(Key,Weight)] -> O.PriorityQueue Int deleteO xs = foldl' (\p k -> snd (O.delete k p)) pq ks where !pq = createO xs O.empty (ks,_) = unzip xs createO :: [(Key,Weight)] -> O.PriorityQueue Int -> O.PriorityQueue Int createO [] !q = q createO ((k,w):xs) !q = createO xs q' where !q' = O.enqueue k w k q ---------------------------------------------------------------- enqdeqP :: [(Key,Weight)] -> P.PriorityQueue Int enqdeqP xs = loop pq numOfTrials where !pq = createP xs P.empty loop !q 0 = q loop !q !n = case P.dequeue q of Nothing -> error "enqdeqP" Just (k,w,x,q') -> loop (P.enqueue k w x q') (n - 1) deleteP :: [(Key,Weight)] -> P.PriorityQueue Int deleteP xs = foldl' (\p k -> snd (P.delete k p)) pq ks where !pq = createP xs P.empty (ks,_) = unzip xs createP :: [(Key,Weight)] -> P.PriorityQueue Int -> P.PriorityQueue Int createP [] !q = q createP ((k,w):xs) !q = createP xs (P.enqueue k w k q) ---------------------------------------------------------------- enqdeqB :: [(Key,Weight)] -> IO () enqdeqB xs = do q <- atomically (B.new numOfStreams) createB xs q loop q numOfTrials where loop _ 0 = return () loop q !n = do Just (k,w,x) <- atomically $ B.dequeue q atomically $ B.enqueue k w x q loop q (n - 1) deleteB :: [(Key,Weight)] -> IO () deleteB xs = do q <- atomically $ B.new numOfStreams createB xs q mapM_ (\k -> atomically $ B.delete k q) keys where (keys,_) = unzip xs createB :: [(Key,Weight)] -> B.PriorityQueue Int -> IO () createB [] _ = return () createB ((k,w):xs) !q = do atomically $ B.enqueue k w k q createB xs q ---------------------------------------------------------------- enqdeqBIO :: [(Key,Weight)] -> IO () enqdeqBIO xs = do q <- BIO.new numOfStreams createBIO xs q loop q numOfTrials where loop _ 0 = return () loop q !n = do Just (k,w,x) <- BIO.dequeue q BIO.enqueue k w x q loop q (n - 1) deleteBIO :: [(Key,Weight)] -> IO () deleteBIO xs = do q <- BIO.new numOfStreams createBIO xs q mapM_ (\k -> BIO.delete k q) keys where (keys,_) = unzip xs createBIO :: [(Key,Weight)] -> BIO.PriorityQueue Int -> IO () createBIO [] _ = return () createBIO ((k,w):xs) !q = do BIO.enqueue k w k q createBIO xs q ---------------------------------------------------------------- enqdeqA :: [(Key,Weight)] -> IO () enqdeqA xs = do q <- atomically A.new createA xs q loop q numOfTrials where loop _ 0 = return () loop q !n = do Just (k,w,x) <- atomically $ A.dequeue q atomically $ A.enqueue k w x q loop q (n - 1) createA :: [(Key,Weight)] -> A.PriorityQueue Int -> IO () createA [] _ = return () createA ((k,w):xs) !q = do atomically $ A.enqueue k w k q createA xs q ---------------------------------------------------------------- enqdeqAIO :: [(Key,Weight)] -> IO () enqdeqAIO xs = do q <- AIO.new createAIO xs q loop q numOfTrials where loop _ 0 = return () loop q !n = do Just (k,w,x) <- AIO.dequeue q AIO.enqueue k w x q loop q (n - 1) deleteAIO :: [(Key,Weight)] -> IO () deleteAIO xs = do q <- AIO.new createAIO xs q mapM_ (\k -> AIO.delete k q) keys where (keys,_) = unzip xs createAIO :: [(Key,Weight)] -> AIO.PriorityQueue Int -> IO () createAIO [] _ = return () createAIO ((k,w):xs) !q = do AIO.enqueue k w k q createAIO xs q ---------------------------------------------------------------- http2-1.3.1/Network/0000755000000000000000000000000012624764141012403 5ustar0000000000000000http2-1.3.1/Network/HPACK.hs0000644000000000000000000000525712624764141013576 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | HPACK() encoding and decoding a header list. module Network.HPACK ( -- * Encoding and decoding HPACKEncoding , HPACKDecoding , encodeHeader , decodeHeader -- * Encoding with builders , HPACKEncodingBuilder , encodeHeaderBuilder -- * DynamicTable , DynamicTable , defaultDynamicTableSize , newDynamicTableForEncoding , newDynamicTableForDecoding , setLimitForEncoding -- * Strategy for encoding , CompressionAlgo(..) , EncodeStrategy(..) , defaultEncodeStrategy -- * Errors for decoding , DecodeError(..) -- * Headers , HeaderList , Header , HeaderName , HeaderValue -- * Basic types , Size , Index ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif import Control.Arrow (second) import Control.Exception (throwIO) import Data.ByteString (ByteString) import Data.ByteString.Builder (Builder) import Network.HPACK.HeaderBlock (toHeaderBlock, fromHeaderBlock, toByteString, fromByteString, toBuilder) import Network.HPACK.Table (DynamicTable, Size, newDynamicTableForEncoding, newDynamicTableForDecoding, setLimitForEncoding) import Network.HPACK.Types -- | Default dynamic table size. -- The value is 4,096 bytes: an array has 128 entries. -- -- >>> defaultDynamicTableSize -- 4096 defaultDynamicTableSize :: Int defaultDynamicTableSize = 4096 ---------------------------------------------------------------- -- | HPACK encoding from 'HeaderList' to 'ByteString'. type HPACKEncoding = DynamicTable -> HeaderList -> IO (DynamicTable, ByteString) -- | HPACK encoding from 'HeaderList' to 'Builder'. type HPACKEncodingBuilder = DynamicTable -> HeaderList -> IO (DynamicTable, Builder) -- | HPACK decoding from 'ByteString' to 'HeaderList'. type HPACKDecoding = DynamicTable -> ByteString -> IO (DynamicTable, HeaderList) ---------------------------------------------------------------- -- | Converting 'HeaderList' for HTTP header to the low level format. encodeHeader :: EncodeStrategy -> HPACKEncoding encodeHeader stgy ctx hs = second toBS <$> toHeaderBlock algo ctx hs where algo = compressionAlgo stgy toBS = toByteString (useHuffman stgy) -- | Converting 'HeaderList' for HTTP header to bytestring builder. encodeHeaderBuilder :: EncodeStrategy -> HPACKEncodingBuilder encodeHeaderBuilder stgy ctx hs = second toBB <$> toHeaderBlock algo ctx hs where algo = compressionAlgo stgy toBB = toBuilder (useHuffman stgy) -- | Converting the low level format for HTTP header to 'HeaderList'. -- 'DecodeError' would be thrown. decodeHeader :: HPACKDecoding decodeHeader ctx bs = either throwIO (fromHeaderBlock ctx) ehb where ehb = fromByteString bs http2-1.3.1/Network/HTTP2.hs0000644000000000000000000000412212624764141013577 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | Framing in HTTP\/2(). module Network.HTTP2 ( -- * Frame Frame(..) , FrameHeader(..) , FramePayload(..) , HeaderBlockFragment , Padding , isPaddingDefined -- * Encoding , encodeFrame , encodeFrameChunks , encodeFrameHeader , encodeFrameHeaderBuf , encodeFramePayload , EncodeInfo(..) , encodeInfo , module Network.HTTP2.Decode -- * Frame type ID , FrameTypeId(..) , framePayloadToFrameTypeId -- * Frame type , FrameType , fromFrameTypeId , toFrameTypeId -- * Priority , Priority(..) , Weight , defaultPriority , highestPriority -- * Stream identifier , StreamId , isControl , isRequest , isResponse -- * Stream identifier related , testExclusive , setExclusive , clearExclusive -- * Flags , FrameFlags , defaultFlags , testEndStream , testAck , testEndHeader , testPadded , testPriority , setEndStream , setAck , setEndHeader , setPadded , setPriority -- * SettingsList , SettingsList , SettingsKeyId(..) , SettingsValue , fromSettingsKeyId , toSettingsKeyId , checkSettingsList -- * Settings , Settings(..) , defaultSettings , updateSettings -- * Window , WindowSize , defaultInitialWindowSize , maxWindowSize , isWindowOverflow -- * Error code , ErrorCode , ErrorCodeId(..) , fromErrorCodeId , toErrorCodeId -- * Error , HTTP2Error(..) , errorCodeId -- * Predefined values , connectionPreface , connectionPrefaceLength , frameHeaderLength , maxPayloadLength , recommendedConcurrency ) where import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Network.HTTP2.Decode import Network.HTTP2.Encode import Network.HTTP2.Types -- | The preface of HTTP\/2. -- -- >>> connectionPreface -- "PRI * HTTP/2.0\r\n\r\nSM\r\n\r\n" connectionPreface :: ByteString connectionPreface = "PRI * HTTP/2.0\r\n\r\nSM\r\n\r\n" -- | Length of the preface. -- -- >>> connectionPrefaceLength -- 24 connectionPrefaceLength :: Int connectionPrefaceLength = BS.length connectionPreface http2-1.3.1/Network/HPACK/0000755000000000000000000000000012624764141013231 5ustar0000000000000000http2-1.3.1/Network/HPACK/Builder.hs0000644000000000000000000000045712624764141015161 0ustar0000000000000000module Network.HPACK.Builder where newtype Builder a = Builder ([a] -> [a]) (<<) :: Builder a -> a -> Builder a Builder b << entry = Builder $ b . (entry :) empty :: Builder a empty = Builder id singleton :: a -> Builder a singleton x = Builder (x :) run :: Builder a -> [a] run (Builder b) = b [] http2-1.3.1/Network/HPACK/HeaderBlock.hs0000644000000000000000000000100212624764141015721 0ustar0000000000000000module Network.HPACK.HeaderBlock ( -- * Types for header block module Network.HPACK.HeaderBlock.HeaderField -- * Header block from/to Low level , toByteString , fromByteString , fromByteStringDebug , toBuilder -- * Header block from/to header list , toHeaderBlock , fromHeaderBlock ) where import Network.HPACK.HeaderBlock.Decode import Network.HPACK.HeaderBlock.Encode import Network.HPACK.HeaderBlock.From import Network.HPACK.HeaderBlock.HeaderField import Network.HPACK.HeaderBlock.To http2-1.3.1/Network/HPACK/Huffman.hs0000644000000000000000000000032512624764141015151 0ustar0000000000000000module Network.HPACK.Huffman ( -- * Type HuffmanEncoding , HuffmanDecoding -- * Encoding/decoding , encode , decode ) where import Network.HPACK.Huffman.Decode import Network.HPACK.Huffman.Encode http2-1.3.1/Network/HPACK/Table.hs0000644000000000000000000000561212624764141014620 0ustar0000000000000000{-# LANGUAGE TupleSections, RecordWildCards, CPP #-} module Network.HPACK.Table ( -- * dynamic table DynamicTable , newDynamicTableForEncoding , newDynamicTableForDecoding , renewDynamicTable , printDynamicTable , isDynamicTableEmpty , isSuitableSize , TableSizeAction(..) , needChangeTableSize , setLimitForEncoding , resetLimitForEncoding -- * Insertion , insertEntry -- * Header to index , HeaderCache(..) , lookupTable -- * Entry , module Network.HPACK.Table.Entry -- * Which tables , WhichTable(..) , which ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif import Control.Exception (throwIO) import Network.HPACK.Table.Dynamic import Network.HPACK.Table.Entry import qualified Network.HPACK.Table.DoubleHashMap as DHM import Network.HPACK.Table.Static import Network.HPACK.Types ---------------------------------------------------------------- -- | Which table does `Index` refer to? data WhichTable = InDynamicTable | InStaticTable deriving (Eq,Show) -- | Is header key-value stored in the tables? data HeaderCache = None | KeyOnly WhichTable Index | KeyValue WhichTable Index deriving Show ---------------------------------------------------------------- -- | Resolving an index from a header. -- Static table is prefer to dynamic table. lookupTable :: Header -> DynamicTable -> HeaderCache lookupTable h dyntbl = case reverseIndex dyntbl of Nothing -> None Just rev -> case DHM.search h rev of DHM.N -> case mstatic of DHM.N -> None DHM.K sidx -> KeyOnly InStaticTable (fromSIndexToIndex dyntbl sidx) DHM.KV sidx -> KeyValue InStaticTable (fromSIndexToIndex dyntbl sidx) DHM.K hidx -> case mstatic of DHM.N -> KeyOnly InDynamicTable (fromHIndexToIndex dyntbl hidx) DHM.K sidx -> KeyOnly InStaticTable (fromSIndexToIndex dyntbl sidx) DHM.KV sidx -> KeyValue InStaticTable (fromSIndexToIndex dyntbl sidx) DHM.KV hidx -> case mstatic of DHM.N -> KeyValue InDynamicTable (fromHIndexToIndex dyntbl hidx) DHM.K _ -> KeyValue InDynamicTable (fromHIndexToIndex dyntbl hidx) DHM.KV sidx -> KeyValue InStaticTable (fromSIndexToIndex dyntbl sidx) where mstatic = DHM.search h staticHashMap ---------------------------------------------------------------- isIn :: Int -> DynamicTable -> Bool isIn idx DynamicTable{..} = idx > staticTableSize -- | Which table does 'Index' belong to? which :: DynamicTable -> Index -> IO (WhichTable, Entry) which dyntbl idx | idx `isIn` dyntbl = (InDynamicTable,) <$> toHeaderEntry dyntbl hidx | isSIndexValid sidx = return (InStaticTable, toStaticEntry sidx) | otherwise = throwIO $ IndexOverrun idx where hidx = fromIndexToHIndex dyntbl idx sidx = fromIndexToSIndex dyntbl idx http2-1.3.1/Network/HPACK/Types.hs0000644000000000000000000000425312624764141014675 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} module Network.HPACK.Types ( -- * Header HeaderName , HeaderValue , HeaderStuff , Header , HeaderList -- * Misc , Index -- * Encoding and decoding , CompressionAlgo(..) , EncodeStrategy(..) , defaultEncodeStrategy , DecodeError(..) ) where import Control.Exception as E import Data.ByteString (ByteString) import Data.Typeable -- | Header name. type HeaderName = ByteString -- | Header value. type HeaderValue = ByteString -- | Header. type Header = (HeaderName, HeaderValue) -- | Header list. type HeaderList = [Header] -- | To be a 'HeaderName' or 'HeaderValue'. type HeaderStuff = ByteString -- | Index for table. type Index = Int -- | Compression algorithms for HPACK encoding. data CompressionAlgo = Naive -- ^ No compression | Static -- ^ Using the static table only | Linear -- ^ Using indices only deriving (Eq, Show) -- | Strategy for HPACK encoding. data EncodeStrategy = EncodeStrategy { -- | Which compression algorithm is used. compressionAlgo :: CompressionAlgo -- | Whether or not to use Huffman encoding for strings. , useHuffman :: Bool } deriving (Eq, Show) -- | Default 'EncodeStrategy'. -- -- >>> defaultEncodeStrategy -- EncodeStrategy {compressionAlgo = Linear, useHuffman = True} defaultEncodeStrategy :: EncodeStrategy defaultEncodeStrategy = EncodeStrategy { compressionAlgo = Linear , useHuffman = True } -- | Errors for decoder. data DecodeError = IndexOverrun Index -- ^ Index is out of range | EosInTheMiddle -- ^ Eos appears in the middle of huffman string | IllegalEos -- ^ Non-eos appears in the end of huffman string | TooLongEos -- ^ Eos of huffman string is more than 7 bits | EmptyEncodedString -- ^ Encoded string has no length | EmptyBlock -- ^ Header block is empty | TooLargeTableSize -- ^ A peer tried to change the dynamic table size over the limit | IllegalTableSizeUpdate -- ^ Table size update at the non-beginning deriving (Eq,Show,Typeable) instance Exception DecodeError http2-1.3.1/Network/HPACK/Builder/0000755000000000000000000000000012624764141014617 5ustar0000000000000000http2-1.3.1/Network/HPACK/Builder/Word8.hs0000644000000000000000000000131512624764141016156 0ustar0000000000000000module Network.HPACK.Builder.Word8 where import Data.ByteString.Internal (ByteString, unsafeCreate) import Data.Word (Word8) import Foreign.Storable (poke) import Foreign.Ptr (plusPtr) data Word8Builder = Word8Builder !Int ([Word8] -> [Word8]) (<|) :: Word8Builder -> Word8 -> Word8Builder Word8Builder i b <| w = Word8Builder (i+1) $ b . (w :) w8empty :: Word8Builder w8empty = Word8Builder 0 id {- singleton :: Word8 -> Word8Builder singleton x = Word8Builder 1 (x :) -} toByteString :: Word8Builder -> ByteString toByteString (Word8Builder i b) = unsafeCreate i $ \ptr -> go ptr ws where ws = b [] go _ [] = return () go ptr (x:xs) = do poke ptr x go (ptr `plusPtr` 1) xs http2-1.3.1/Network/HPACK/HeaderBlock/0000755000000000000000000000000012624764141015374 5ustar0000000000000000http2-1.3.1/Network/HPACK/HeaderBlock/Decode.hs0000644000000000000000000001043612624764141017117 0ustar0000000000000000module Network.HPACK.HeaderBlock.Decode ( fromByteString , fromByteStringDebug ) where import Data.Bits (testBit, clearBit, (.&.)) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Word (Word8) import Network.HPACK.Builder import Network.HPACK.HeaderBlock.HeaderField import qualified Network.HPACK.HeaderBlock.Integer as I import qualified Network.HPACK.HeaderBlock.String as S import Network.HPACK.Types ---------------------------------------------------------------- -- | Converting the low level format to 'HeaderBlock'. fromByteString :: ByteString -> Either DecodeError HeaderBlock fromByteString inp = go inp empty where go bs builder | BS.null bs = Right $ run builder | otherwise = do (hf, bs') <- toHeaderField bs go bs' (builder << hf) -- | Converting the low level format to 'HeaderBlock'. -- 'HeaderBlock' forms a pair with corresponding 'ByteString'. fromByteStringDebug :: ByteString -> Either DecodeError [(ByteString,HeaderField)] fromByteStringDebug inp = go inp empty where go bs builder | BS.null bs = Right $ run builder | otherwise = do (hf, bs') <- toHeaderField bs let len = BS.length bs - BS.length bs' consumed = BS.take len bs go bs' (builder << (consumed,hf)) toHeaderField :: ByteString -> Either DecodeError (HeaderField, ByteString) toHeaderField bs | BS.null bs = Left EmptyBlock | w `testBit` 7 = indexed w bs' | w `testBit` 6 = incrementalIndexing w bs' | w `testBit` 5 = maxSize w bs' | w `testBit` 4 = neverIndexing w bs' | otherwise = withoutIndexing w bs' where w = BS.head bs bs' = BS.tail bs ---------------------------------------------------------------- indexed :: Word8 -> ByteString -> Either DecodeError (HeaderField, ByteString) indexed w ws = Right (Indexed idx , ws') where w' = clearBit w 7 (idx, ws') = I.parseInteger 7 w' ws incrementalIndexing :: Word8 -> ByteString -> Either DecodeError (HeaderField, ByteString) incrementalIndexing w ws | isIndexedName1 w = indexedName Add w ws 6 mask6 | otherwise = newName Add ws maxSize :: Word8 -> ByteString -> Either DecodeError (HeaderField, ByteString) maxSize w ws = Right (ChangeTableSize siz, ws') where w' = mask5 w (siz, ws') = I.parseInteger 5 w' ws withoutIndexing :: Word8 -> ByteString -> Either DecodeError (HeaderField, ByteString) withoutIndexing w ws | isIndexedName2 w = indexedName NotAdd w ws 4 mask4 | otherwise = newName NotAdd ws neverIndexing :: Word8 -> ByteString -> Either DecodeError (HeaderField, ByteString) neverIndexing w ws | isIndexedName2 w = indexedName Never w ws 4 mask4 | otherwise = newName Never ws ---------------------------------------------------------------- indexedName :: Indexing -> Word8 -> ByteString -> Int -> (Word8 -> Word8) -> Either DecodeError (HeaderField, ByteString) indexedName indexing w ws n mask = do (val,ws'') <- headerStuff ws' let hf = Literal indexing (Idx idx) val return (hf, ws'') where p = mask w (idx,ws') = I.parseInteger n p ws newName :: Indexing -> ByteString -> Either DecodeError (HeaderField, ByteString) newName indexing ws = do (key,ws') <- headerStuff ws (val,ws'') <- headerStuff ws' let hf = Literal indexing (Lit key) val return (hf, ws'') ---------------------------------------------------------------- headerStuff :: ByteString -> Either DecodeError (HeaderStuff, ByteString) headerStuff bs | BS.null bs = Left EmptyEncodedString | otherwise = S.parseString huff len bs'' where w = BS.head bs bs' = BS.tail bs p = dropHuffman w huff = isHuffman w (len, bs'') = I.parseInteger 7 p bs' ---------------------------------------------------------------- mask6 :: Word8 -> Word8 mask6 w = w .&. 63 mask5 :: Word8 -> Word8 mask5 w = w .&. 31 mask4 :: Word8 -> Word8 mask4 w = w .&. 15 isIndexedName1 :: Word8 -> Bool isIndexedName1 w = mask6 w /= 0 isIndexedName2 :: Word8 -> Bool isIndexedName2 w = mask4 w /= 0 ---------------------------------------------------------------- isHuffman :: Word8 -> Bool isHuffman w = w `testBit` 7 dropHuffman :: Word8 -> Word8 dropHuffman w = w `clearBit` 7 http2-1.3.1/Network/HPACK/HeaderBlock/Encode.hs0000644000000000000000000000662412624764141017135 0ustar0000000000000000{-# LANGUAGE CPP #-} module Network.HPACK.HeaderBlock.Encode ( toByteString , toBuilder ) where import Data.Bits (setBit) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Builder.Prim as P import qualified Data.ByteString.Lazy as BL import Data.List (foldl') #if __GLASGOW_HASKELL__ < 709 import Data.Monoid (mempty) #endif import Data.Monoid ((<>)) import Data.Word (Word8) import Network.HPACK.HeaderBlock.HeaderField import qualified Network.HPACK.HeaderBlock.Integer as I import qualified Network.HPACK.HeaderBlock.String as S ---------------------------------------------------------------- -- | Converting 'HeaderBlock' to the low level format. toByteString :: Bool -> HeaderBlock -> ByteString toByteString huff hbs = BL.toStrict $ BB.toLazyByteString $ toBuilder huff hbs toBuilder :: Bool -> [HeaderField] -> Builder toBuilder huff hbs = foldl' op mempty hbs where b `op` x = b <> toBB x toBB = fromHeaderField huff fromHeaderField :: Bool -> HeaderField -> Builder fromHeaderField _ (ChangeTableSize siz) = change siz fromHeaderField _ (Indexed idx) = index idx fromHeaderField huff (Literal Add (Idx idx) v) = indexedName huff 6 set01 idx v fromHeaderField huff (Literal Add (Lit key) v) = newName huff set01 key v fromHeaderField huff (Literal NotAdd (Idx idx) v) = indexedName huff 4 set0000 idx v fromHeaderField huff (Literal NotAdd (Lit key) v) = newName huff set0000 key v fromHeaderField huff (Literal Never (Idx idx) v) = indexedName huff 4 set0001 idx v fromHeaderField huff (Literal Never (Lit key) v) = newName huff set0001 key v ---------------------------------------------------------------- word8s :: [Word8] -> Builder word8s = P.primMapListFixed P.word8 change :: Int -> Builder change i = word8s (w':ws) where (w:ws) = I.encode 5 i w' = set001 w index :: Int -> Builder index i = word8s (w':ws) where (w:ws) = I.encode 7 i w' = set1 w -- Using Huffman encoding indexedName :: Bool -> Int -> Setter -> Int -> HeaderValue -> Builder indexedName huff n set idx v = pre <> vlen <> val where (p:ps) = I.encode n idx pre = word8s $ set p : ps value = S.encode huff v valueLen = BS.length value vlen | huff = word8s $ setH $ I.encode 7 valueLen | otherwise = word8s $ I.encode 7 valueLen val = BB.byteString value -- Using Huffman encoding newName :: Bool -> Setter -> HeaderName -> HeaderValue -> Builder newName huff set k v = pre <> klen <> key <> vlen <> val where pre = BB.word8 $ set 0 key0 = S.encode huff k keyLen = BS.length key0 value = S.encode huff v valueLen = BS.length value klen | huff = word8s $ setH $ I.encode 7 keyLen | otherwise = word8s $ I.encode 7 keyLen vlen | huff = word8s $ setH $ I.encode 7 valueLen | otherwise = word8s $ I.encode 7 valueLen key = BB.byteString key0 val = BB.byteString value ---------------------------------------------------------------- type Setter = Word8 -> Word8 -- Assuming MSBs are 0. set1, set01, set001, set0001, set0000 :: Setter set1 x = x `setBit` 7 set01 x = x `setBit` 6 set001 x = x `setBit` 5 set0001 x = x `setBit` 4 set0000 = id setH :: [Word8] -> [Word8] setH [] = error "setH" setH (x:xs) = (x `setBit` 7) : xs http2-1.3.1/Network/HPACK/HeaderBlock/From.hs0000644000000000000000000000515212624764141016636 0ustar0000000000000000{-# LANGUAGE BangPatterns, CPP #-} module Network.HPACK.HeaderBlock.From ( fromHeaderBlock , decodeStep ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif import Control.Exception (throwIO) import Control.Monad (unless) import Network.HPACK.Builder import Network.HPACK.HeaderBlock.HeaderField import Network.HPACK.Table import Network.HPACK.Types ---------------------------------------------------------------- type Ctx = (DynamicTable, Builder Header, Bool) type Step = Ctx -> HeaderField -> IO Ctx -- | Decoding 'HeaderBlock' to 'HeaderList'. fromHeaderBlock :: DynamicTable -> HeaderBlock -> IO (DynamicTable, HeaderList) fromHeaderBlock !dyntbl rs = decodeLoop rs (dyntbl,empty,True) ---------------------------------------------------------------- decodeLoop :: HeaderBlock -> Ctx -> IO (DynamicTable, HeaderList) decodeLoop (r:rs) !dyntbl = decodeStep dyntbl r >>= decodeLoop rs decodeLoop [] !dyntbl = decodeFinal dyntbl ---------------------------------------------------------------- -- | Decoding step for one 'HeaderField'. Exporting for the -- test purpose. decodeStep :: Step decodeStep (!dyntbl,!builder,beginning) (ChangeTableSize siz) | beginning = do unless (isSuitableSize siz dyntbl) $ throwIO TooLargeTableSize dyntbl' <- renewDynamicTable siz dyntbl return (dyntbl',builder,True) | otherwise = throwIO IllegalTableSizeUpdate decodeStep (!dyntbl,!builder,_) (Indexed idx) = do w <- which dyntbl idx case w of (InStaticTable, e) -> do let b = builder << fromEntry e return (dyntbl,b,False) (InDynamicTable, e) -> do let b = builder << fromEntry e return (dyntbl,b,False) decodeStep (!dyntbl,!builder,_) (Literal NotAdd naming v) = do k <- fromNaming naming dyntbl let b = builder << (k,v) return (dyntbl, b, False) decodeStep (!dyntbl,!builder,_) (Literal Never naming v) = do k <- fromNaming naming dyntbl let b = builder << (k,v) return (dyntbl, b, False) decodeStep (!dyntbl,!builder,_) (Literal Add naming v) = do k <- fromNaming naming dyntbl let h = (k,v) e = toEntry (k,v) b = builder << h dyntbl' <- insertEntry e dyntbl return (dyntbl',b,False) decodeFinal :: Ctx -> IO (DynamicTable, HeaderList) decodeFinal (!dyntbl,!builder,_) = return (dyntbl, run builder) ---------------------------------------------------------------- fromNaming :: Naming -> DynamicTable -> IO HeaderName fromNaming (Lit k) _ = return k fromNaming (Idx idx) dyntbl = entryHeaderName . snd <$> which dyntbl idx http2-1.3.1/Network/HPACK/HeaderBlock/HeaderField.hs0000644000000000000000000000154012624764141020064 0ustar0000000000000000module Network.HPACK.HeaderBlock.HeaderField ( -- * Type HeaderBlock , emptyHeaderBlock , HeaderField(..) , HeaderName -- re-exporting , HeaderValue -- re-exporting , Index -- re-exporting , Indexing(..) , Naming(..) ) where import Network.HPACK.Types ---------------------------------------------------------------- -- | Type for header block. type HeaderBlock = [HeaderField] -- | Empty header block. emptyHeaderBlock :: HeaderBlock emptyHeaderBlock = [] -- | Type for representation. data HeaderField = ChangeTableSize Int | Indexed Index | Literal Indexing Naming HeaderValue deriving (Eq,Show) -- | Whether or not adding to a table. data Indexing = Add | NotAdd | Never deriving (Eq,Show) -- | Index or literal. data Naming = Idx Index | Lit HeaderName deriving (Eq,Show) http2-1.3.1/Network/HPACK/HeaderBlock/Integer.hs0000644000000000000000000000524512624764141017333 0ustar0000000000000000{-# LANGUAGE BangPatterns, OverloadedStrings #-} module Network.HPACK.HeaderBlock.Integer ( encode , decode , parseInteger ) where import Data.Array (Array, listArray, (!)) import Data.Bits ((.&.), shiftR) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Word (Word8) -- $setup -- >>> import qualified Data.ByteString as BS ---------------------------------------------------------------- powerArray :: Array Int Int powerArray = listArray (1,8) [1,3,7,15,31,63,127,255] ---------------------------------------------------------------- {- if I < 2^N - 1, encode I on N bits else encode (2^N - 1) on N bits I = I - (2^N - 1) while I >= 128 encode (I % 128 + 128) on 8 bits I = I / 128 encode I on 8 bits -} -- | Integer encoding. The first argument is N of prefix. -- -- >>> encode 5 10 -- [10] -- >>> encode 5 1337 -- [31,154,10] -- >>> encode 8 42 -- [42] encode :: Int -> Int -> [Word8] encode n i | i < p = fromIntegral i : [] | otherwise = fromIntegral p : encode' (i - p) where p = powerArray ! n encode' :: Int -> [Word8] encode' i | i < 128 = fromIntegral i : [] | otherwise = fromIntegral (r + 128) : encode' q where -- (q,r) = i `divMod` 128 q = i `shiftR` 7 r = i .&. 0x7f ---------------------------------------------------------------- {- decode I from the next N bits if I < 2^N - 1, return I else M = 0 repeat B = next octet I = I + (B & 127) * 2^M M = M + 7 while B & 128 == 128 return I -} -- | Integer decoding. The first argument is N of prefix. -- -- >>> decode 5 10 $ BS.empty -- 10 -- >>> decode 5 31 $ BS.pack [154,10] -- 1337 -- >>> decode 8 42 $ BS.empty -- 42 decode :: Int -> Word8 -> ByteString -> Int decode n w bs | i < p = i | BS.null bs = error $ "decode: n = " ++ show n ++ ", w = " ++ show w ++ ", bs = empty" | otherwise = decode' bs 0 i where p = powerArray ! n i = fromIntegral w decode' :: ByteString -> Int -> Int -> Int decode' "" _ i = i decode' bs m i = decode' bs' m' i' where !b = fromIntegral $ BS.head bs !bs' = BS.tail bs !i' = i + (b .&. 127) * 2 ^ m !m' = m + 7 ---------------------------------------------------------------- -- | -- -- >>> parseInteger 7 127 $ BS.pack [210,211,212,87,88,89,90] -- (183839313,"XYZ") parseInteger :: Int -> Word8 -> ByteString -> (Int, ByteString) parseInteger n w bs | i < p = (i, bs) | otherwise = (len, rest) where p = powerArray ! n i = fromIntegral w Just idx = BS.findIndex (< 128) bs (bs', rest) = BS.splitAt (idx + 1) bs len = decode n w bs' http2-1.3.1/Network/HPACK/HeaderBlock/String.hs0000644000000000000000000000155212624764141017201 0ustar0000000000000000module Network.HPACK.HeaderBlock.String ( encode , parseString ) where import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Network.HPACK.Huffman as Huffman import Network.HPACK.Types -- | Encoding 'HeaderStuff' to 'ByteString' according to 'HuffmanEncoding'. encode :: Bool -> HeaderStuff -> ByteString encode True h = Huffman.encode h encode _ h = h -- | Parsing 'HeaderStuff' from 'ByteString'. -- The second 'Bool' is whether or not huffman encoding is used. -- The third 'Int' is the length of the encoded string. parseString :: Bool -> Int -> ByteString -> Either DecodeError (HeaderStuff, ByteString) parseString False len bs = Right (es, bs') where (es, bs') = BS.splitAt len bs parseString True len bs = Huffman.decode es >>= \x -> return (x,bs') where (es, bs') = BS.splitAt len bs http2-1.3.1/Network/HPACK/HeaderBlock/To.hs0000644000000000000000000000750712624764141016323 0ustar0000000000000000{-# LANGUAGE BangPatterns, OverloadedStrings, CPP #-} module Network.HPACK.HeaderBlock.To ( toHeaderBlock ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif import Control.Arrow (second) import Network.HPACK.Builder import Network.HPACK.HeaderBlock.HeaderField import Network.HPACK.Table import Network.HPACK.Types type Ctx = (DynamicTable, Builder HeaderField) type Step = Ctx -> Header -> IO Ctx -- | Encoding 'HeaderList' to 'HeaderBlock'. toHeaderBlock :: CompressionAlgo -> DynamicTable -> HeaderList -> IO (DynamicTable, HeaderBlock) toHeaderBlock algo !dyntbl hs = do msiz <- needChangeTableSize dyntbl (dyntbl', op) <- case msiz of Keep -> do return (dyntbl, id) Change lim -> do tbl <- renewDynamicTable lim dyntbl return (tbl, (ChangeTableSize lim :)) Ignore lim -> do resetLimitForEncoding dyntbl return (dyntbl, (ChangeTableSize lim :)) second op <$> toHeaderBlock' algo dyntbl' hs toHeaderBlock' :: CompressionAlgo -> DynamicTable -> HeaderList -> IO (DynamicTable, HeaderBlock) toHeaderBlock' Naive !dyntbl hs = encodeLoop naiveStep hs (dyntbl,empty) toHeaderBlock' Static !dyntbl hs = encodeLoop staticStep hs (dyntbl,empty) toHeaderBlock' Linear !dyntbl hs = encodeLoop linearStep hs (dyntbl,empty) ---------------------------------------------------------------- encodeFinal :: Ctx -> IO (DynamicTable, HeaderBlock) encodeFinal (!dyntbl, !builder) = return (dyntbl, run builder) encodeLoop :: Step -> HeaderList -> Ctx -> IO (DynamicTable, HeaderBlock) encodeLoop step (h:hs) !dyntbl = step dyntbl h >>= encodeLoop step hs encodeLoop _ [] !dyntbl = encodeFinal dyntbl ---------------------------------------------------------------- naiveStep :: Step naiveStep (!dyntbl,!builder) (k,v) = do let builder' = builder << Literal NotAdd (Lit k) v return (dyntbl, builder') ---------------------------------------------------------------- staticStep :: Step staticStep (!dyntbl,!builder) h@(k,v) = return (dyntbl, builder') where b = case lookupTable h dyntbl of None -> Literal NotAdd (Lit k) v KeyOnly InStaticTable i -> Literal NotAdd (Idx i) v KeyOnly InDynamicTable _ -> Literal NotAdd (Lit k) v KeyValue InStaticTable i -> Literal NotAdd (Idx i) v KeyValue InDynamicTable _ -> Literal NotAdd (Lit k) v builder' = builder << b ---------------------------------------------------------------- -- A simple encoding strategy to reset the reference set first -- by 'Index 0' and uses indexing as much as possible. linearStep :: Step linearStep cb@(!dyntbl,!builder) h = smartStep linear cb h where linear i = return (dyntbl,builder << Indexed i) ---------------------------------------------------------------- smartStep :: (Index -> IO Ctx) -> Step smartStep func cb@(!dyntbl,!builder) h@(k,_) = do let cache = lookupTable h dyntbl case cache of None -> check cb h (Lit k) KeyOnly InStaticTable i -> check cb h (Idx i) KeyOnly InDynamicTable i -> check cb h (Idx i) KeyValue InStaticTable i -> return (dyntbl, builder << Indexed i) KeyValue InDynamicTable i -> func i check :: Ctx -> Header -> Naming -> IO Ctx check (dyntbl,builder) h@(k,v) x | k `elem` headersNotToIndex = do let builder' = builder << Literal NotAdd x v return (dyntbl, builder') | otherwise = do let e = toEntry h dyntbl' <- insertEntry e dyntbl let builder' = builder << Literal Add x v return (dyntbl', builder') headersNotToIndex :: [HeaderName] headersNotToIndex = [ ":path" , "content-length" , "location" , "etag" , "set-cookie" ] http2-1.3.1/Network/HPACK/Huffman/0000755000000000000000000000000012624764141014615 5ustar0000000000000000http2-1.3.1/Network/HPACK/Huffman/Bit.hs0000644000000000000000000000102012624764141015660 0ustar0000000000000000module Network.HPACK.Huffman.Bit ( -- * Bits B(..) , Bits , fromBits ) where import Data.Word (Word8) import Data.List (foldl') -- | Data type for Bit. data B = F -- ^ Zero | T -- ^ One deriving (Eq,Ord,Show) -- | Bit stream. type Bits = [B] fromBit :: B -> Word8 fromBit F = 0 fromBit T = 1 -- | From 'Bits' of length 8 to 'Word8'. -- -- >>> fromBits [T,F,T,F,T,F,T,F] -- 170 -- >>> fromBits [F,T,F,T,F,T,F,T] -- 85 fromBits :: Bits -> Word8 fromBits = foldl' (\x y -> x * 2 + y) 0 . map fromBit http2-1.3.1/Network/HPACK/Huffman/ByteString.hs0000644000000000000000000000272412624764141017250 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface #-} module Network.HPACK.Huffman.ByteString ( unpack4bits , copy ) where import Control.Monad (void) import Data.Bits ((.&.), shiftR) import Data.ByteString.Internal (ByteString(..)) import Data.Word (Word8) import Foreign.C.Types (CSize(..)) import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (Ptr, plusPtr) import Foreign.Storable (peek) import System.IO.Unsafe (unsafeDupablePerformIO) -- $setup -- >>> import qualified Data.ByteString as BS -- | -- -- >>> let bs = BS.pack [0x12,0x34,0xf3,0xab] -- >>> unpack4bits bs -- [1,2,3,4,15,3,10,11] -- >>> unpack4bits $ BS.tail bs -- [3,4,15,3,10,11] unpack4bits :: ByteString -> [Word8] unpack4bits (PS fptr off len) = unsafeDupablePerformIO $ withForeignPtr fptr $ \ptr -> do let lim = ptr `plusPtr` (off - 1) end = ptr `plusPtr` (off + len - 1) go lim end [] where go lim p ws | lim == p = return ws | otherwise = do w <- peek p let w0 = w `shiftR` 4 w1 = w .&. 0xf go lim (p `plusPtr` (-1)) (w0:w1:ws) copy :: Ptr Word8 -> ByteString -> IO () copy dst (PS fptr off len) = withForeignPtr fptr $ \ptr -> do let beg = ptr `plusPtr` off memcpy dst beg (fromIntegral len) foreign import ccall unsafe "string.h memcpy" c_memcpy :: Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8) memcpy :: Ptr Word8 -> Ptr Word8 -> Int -> IO () memcpy dst src s = void $ c_memcpy dst src (fromIntegral s) http2-1.3.1/Network/HPACK/Huffman/Decode.hs0000644000000000000000000000563312624764141016343 0ustar0000000000000000module Network.HPACK.Huffman.Decode ( -- * Huffman decoding HuffmanDecoding , decode ) where import Data.ByteString (ByteString) import Data.Array (Array, (!), listArray) import Data.Word (Word8) import Network.HPACK.Builder.Word8 import Network.HPACK.Huffman.Bit import Network.HPACK.Huffman.ByteString import Network.HPACK.Huffman.Params import Network.HPACK.Huffman.Table import Network.HPACK.Huffman.Tree import Network.HPACK.Types (DecodeError(..)) ---------------------------------------------------------------- -- | Huffman decoding. type HuffmanDecoding = ByteString -> Either DecodeError ByteString ---------------------------------------------------------------- data Pin = EndOfString | Forward {-# UNPACK #-} !Word8 -- node no. | GoBack {-# UNPACK #-} !Word8 -- node no. {-# UNPACK #-} !Word8 -- a decoded value deriving Show data Way16 = Way16 (Maybe Int) (Array Word8 Pin) type Way256 = Array Word8 Way16 next :: Way16 -> Word8 -> Pin next (Way16 _ a16) w = a16 ! w ---------------------------------------------------------------- -- | Huffman decoding. decode :: HuffmanDecoding decode bs = dec qs where qs = unpack4bits bs dec :: [Word8] -> Either DecodeError ByteString dec inp = go (way256 ! 0) inp w8empty where go :: Way16 -> [Word8] -> Word8Builder -> Either DecodeError ByteString go (Way16 Nothing _) [] _ = Left IllegalEos go (Way16 (Just i) _) [] builder | i <= 8 = Right $ toByteString builder | otherwise = Left TooLongEos go way (w:ws) builder = case next way w of EndOfString -> Left EosInTheMiddle Forward n -> go (way256 ! n) ws builder GoBack n v -> go (way256 ! n) ws (builder <| v) ---------------------------------------------------------------- way256 :: Way256 way256 = construct $ toHTree huffmanTable construct :: HTree -> Way256 construct decoder = listArray (0,255) $ map to16ways $ flatten decoder where to16ways x = Way16 ei a16 where ei = eosInfo x a16 = listArray (0,15) $ map (step decoder x Nothing) bits4s step :: HTree -> HTree -> Maybe Word8 -> [B] -> Pin step root (Tip _ v) _ bss | v == idxEos = EndOfString | otherwise = let w = fromIntegral v in step root root (Just w) bss step _ (Bin _ n _ _) Nothing [] = Forward (fromIntegral n) step _ (Bin _ n _ _) (Just w) [] = GoBack (fromIntegral n) w step root (Bin _ _ l _) mx (F:bs) = step root l mx bs step root (Bin _ _ _ r) mx (T:bs) = step root r mx bs bits4s :: [[B]] bits4s = [ [F,F,F,F] , [F,F,F,T] , [F,F,T,F] , [F,F,T,T] , [F,T,F,F] , [F,T,F,T] , [F,T,T,F] , [F,T,T,T] , [T,F,F,F] , [T,F,F,T] , [T,F,T,F] , [T,F,T,T] , [T,T,F,F] , [T,T,F,T] , [T,T,T,F] , [T,T,T,T] ] http2-1.3.1/Network/HPACK/Huffman/Encode.hs0000644000000000000000000000656112624764141016356 0ustar0000000000000000{-# LANGUAGE BangPatterns, CPP #-} module Network.HPACK.Huffman.Encode ( -- * Huffman encoding HuffmanEncoding , encode ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif import Control.Monad (when) import Data.Array import Data.Bits ((.|.)) import qualified Data.ByteString as BS import Data.ByteString.Internal (ByteString(..), create) import Data.Word (Word8) import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (Ptr, plusPtr) import Foreign.Storable (peek, poke) import Network.HPACK.Huffman.Bit import Network.HPACK.Huffman.ByteString import Network.HPACK.Huffman.Params import Network.HPACK.Huffman.Table import System.IO.Unsafe (unsafePerformIO) ---------------------------------------------------------------- type AOSA = Array Int ShiftedArray type ShiftedArray = Array Int Shifted data Shifted = Shifted !Int -- Total bytes !Int -- How many bits in the last byte ByteString -- Up to 5 bytes deriving Show ---------------------------------------------------------------- aosa :: AOSA aosa = listArray (0,idxEos) $ map toShiftedArray huffmanTable -- | -- -- >>> toShifted [T,T,T,T] 0 -- Shifted 1 4 "\240" -- >>> toShifted [T,T,T,T] 4 -- Shifted 1 0 "\SI" -- >>> toShifted [T,T,T,T] 5 -- Shifted 2 1 "\a\128" toShifted :: Bits -> Int -> Shifted toShifted bits n = Shifted total r bs where shifted = replicate n F ++ bits len = length shifted (q,r) = len `divMod` 8 total | r == 0 = q | otherwise = q + 1 bs = BS.pack $ map fromBits $ group8 shifted group8 xs | null zs = pad ys : [] | otherwise = ys : group8 zs where (ys,zs) = splitAt 8 xs pad xs = take 8 $ xs ++ repeat F toShiftedArray :: Bits -> ShiftedArray toShiftedArray bits = listArray (0,7) $ map (toShifted bits) [0..7] ---------------------------------------------------------------- -- | Huffman encoding. type HuffmanEncoding = ByteString -> ByteString -- | Huffman encoding. encode :: HuffmanEncoding encode (PS fptr off len) = unsafePerformIO $ withForeignPtr fptr $ \ptr -> do let beg = ptr `plusPtr` off end = beg `plusPtr` len size <- accumSize beg end 0 0 create size (\dst -> go dst 0 beg end) where accumSize :: Ptr Word8 -> Ptr Word8 -> Int -> Int -> IO Int accumSize src lim n acc | src == lim = return acc | otherwise = do i <- fromIntegral <$> peek src let Shifted l n' _ = (aosa ! i) ! n let !acc' | n == 0 = acc + l | otherwise = acc + l - 1 accumSize (src `plusPtr` 1) lim n' acc' go :: Ptr Word8 -> Int -> Ptr Word8 -> Ptr Word8 -> IO () go dst n src lim | src == lim = do when (n /= 0) $ do let Shifted _ _ bs = (aosa ! idxEos) ! n w0 <- peek dst let w1 = BS.head bs poke dst (w0 .|. w1) | otherwise = do i <- fromIntegral <$> peek src let Shifted l n' bs = (aosa ! i) ! n if n == 0 then copy dst bs else do w0 <- peek dst copy dst bs w1 <- peek dst poke dst (w0 .|. w1) let dst' | n' == 0 = dst `plusPtr` l | otherwise = dst `plusPtr` (l - 1) go dst' n' (src `plusPtr` 1) lim http2-1.3.1/Network/HPACK/Huffman/Params.hs0000644000000000000000000000010612624764141016371 0ustar0000000000000000module Network.HPACK.Huffman.Params where idxEos :: Int idxEos = 256 http2-1.3.1/Network/HPACK/Huffman/Table.hs0000644000000000000000000002543612624764141016212 0ustar0000000000000000module Network.HPACK.Huffman.Table where import Network.HPACK.Huffman.Bit huffmanTable :: [Bits] huffmanTable = [ [T,T,T,T,T,T,T,T,T,T,F,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,F,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T] , [F,T,F,T,F,F] , [T,T,T,T,T,T,T,F,F,F] , [T,T,T,T,T,T,T,F,F,T] , [T,T,T,T,T,T,T,T,T,F,T,F] , [T,T,T,T,T,T,T,T,T,T,F,F,T] , [F,T,F,T,F,T] , [T,T,T,T,T,F,F,F] , [T,T,T,T,T,T,T,T,F,T,F] , [T,T,T,T,T,T,T,F,T,F] , [T,T,T,T,T,T,T,F,T,T] , [T,T,T,T,T,F,F,T] , [T,T,T,T,T,T,T,T,F,T,T] , [T,T,T,T,T,F,T,F] , [F,T,F,T,T,F] , [F,T,F,T,T,T] , [F,T,T,F,F,F] , [F,F,F,F,F] , [F,F,F,F,T] , [F,F,F,T,F] , [F,T,T,F,F,T] , [F,T,T,F,T,F] , [F,T,T,F,T,T] , [F,T,T,T,F,F] , [F,T,T,T,F,T] , [F,T,T,T,T,F] , [F,T,T,T,T,T] , [T,F,T,T,T,F,F] , [T,T,T,T,T,F,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,F,F] , [T,F,F,F,F,F] , [T,T,T,T,T,T,T,T,T,F,T,T] , [T,T,T,T,T,T,T,T,F,F] , [T,T,T,T,T,T,T,T,T,T,F,T,F] , [T,F,F,F,F,T] , [T,F,T,T,T,F,T] , [T,F,T,T,T,T,F] , [T,F,T,T,T,T,T] , [T,T,F,F,F,F,F] , [T,T,F,F,F,F,T] , [T,T,F,F,F,T,F] , [T,T,F,F,F,T,T] , [T,T,F,F,T,F,F] , [T,T,F,F,T,F,T] , [T,T,F,F,T,T,F] , [T,T,F,F,T,T,T] , [T,T,F,T,F,F,F] , [T,T,F,T,F,F,T] , [T,T,F,T,F,T,F] , [T,T,F,T,F,T,T] , [T,T,F,T,T,F,F] , [T,T,F,T,T,F,T] , [T,T,F,T,T,T,F] , [T,T,F,T,T,T,T] , [T,T,T,F,F,F,F] , [T,T,T,F,F,F,T] , [T,T,T,F,F,T,F] , [T,T,T,T,T,T,F,F] , [T,T,T,F,F,T,T] , [T,T,T,T,T,T,F,T] , [T,T,T,T,T,T,T,T,T,T,F,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,F] , [T,T,T,T,T,T,T,T,T,T,T,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,F,F] , [T,F,F,F,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,F,T] , [F,F,F,T,T] , [T,F,F,F,T,T] , [F,F,T,F,F] , [T,F,F,T,F,F] , [F,F,T,F,T] , [T,F,F,T,F,T] , [T,F,F,T,T,F] , [T,F,F,T,T,T] , [F,F,T,T,F] , [T,T,T,F,T,F,F] , [T,T,T,F,T,F,T] , [T,F,T,F,F,F] , [T,F,T,F,F,T] , [T,F,T,F,T,F] , [F,F,T,T,T] , [T,F,T,F,T,T] , [T,T,T,F,T,T,F] , [T,F,T,T,F,F] , [F,T,F,F,F] , [F,T,F,F,T] , [T,F,T,T,F,T] , [T,T,T,F,T,T,T] , [T,T,T,T,F,F,F] , [T,T,T,T,F,F,T] , [T,T,T,T,F,T,F] , [T,T,T,T,F,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,F] , [T,T,T,T,T,T,T,T,T,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,F,T] , [T,T,T,T,T,T,T,T,T,T,T,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,F,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,F,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,T,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,T,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,F,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,T,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,F,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,F,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,T,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,T,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,T,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,T,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,T,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,T,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,F,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,F,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,F,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,T,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,F,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,T,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,T,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,T,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,T,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,T,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,T,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,T,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,T,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,T,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,F,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,F,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,F,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,T,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T] ] http2-1.3.1/Network/HPACK/Huffman/Tree.hs0000644000000000000000000000461012624764141016051 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module Network.HPACK.Huffman.Tree ( -- * Huffman decoding HTree(..) , eosInfo , toHTree , showTree , printTree , flatten ) where import Control.Arrow (second) import Data.List (partition) import Network.HPACK.Huffman.Bit import Network.HPACK.Huffman.Params ---------------------------------------------------------------- type EOSInfo = Maybe Int -- | Type for Huffman decoding. data HTree = Tip EOSInfo -- EOS info from 1 {-# UNPACK #-} !Int -- Decoded value. Essentially Word8 | Bin EOSInfo -- EOS info from 1 {-# UNPACK #-} !Int -- Sequence no from 0 HTree -- Left HTree -- Right deriving Show eosInfo :: HTree -> EOSInfo eosInfo (Tip mx _) = mx eosInfo (Bin mx _ _ _) = mx ---------------------------------------------------------------- showTree :: HTree -> String showTree = showTree' "" showTree' :: String -> HTree -> String showTree' _ (Tip _ i) = show i ++ "\n" showTree' pref (Bin _ n l r) = "No " ++ show n ++ "\n" ++ pref ++ "+ " ++ showTree' pref' l ++ pref ++ "+ " ++ showTree' pref' r where pref' = " " ++ pref printTree :: HTree -> IO () printTree = putStr . showTree ---------------------------------------------------------------- -- | Creating 'HTree'. toHTree :: [Bits] -> HTree toHTree bs = mark 1 eos $ snd $ build 0 $ zip [0..idxEos] bs where eos = bs !! idxEos build :: Int -> [(Int,Bits)] -> (Int, HTree) build !cnt0 [(v,[])] = (cnt0,Tip Nothing v) build !cnt0 xs = let (cnt1,l) = build (cnt0 + 1) fs (cnt2,r) = build cnt1 ts in (cnt2, Bin Nothing cnt0 l r) where (fs',ts') = partition ((==) F . head . snd) xs fs = map (second tail) fs' ts = map (second tail) ts' -- | Marking the EOS path mark :: Int -> Bits -> HTree -> HTree mark i [] (Tip Nothing v) = Tip (Just i) v mark i (F:bs) (Bin Nothing n l r) = Bin (Just i) n (mark (i+1) bs l) r mark i (T:bs) (Bin Nothing n l r) = Bin (Just i) n l (mark (i+1) bs r) mark _ _ _ = error "mark" ---------------------------------------------------------------- flatten :: HTree -> [HTree] flatten (Tip _ _) = [] flatten t@(Bin _ _ l r) = t : (flatten l ++ flatten r) http2-1.3.1/Network/HPACK/Table/0000755000000000000000000000000012624764141014260 5ustar0000000000000000http2-1.3.1/Network/HPACK/Table/DoubleHashMap.hs0000644000000000000000000000424212624764141017272 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module Network.HPACK.Table.DoubleHashMap ( DoubleHashMap , empty , insert , delete , fromList , deleteList , Res(..) , search ) where import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as H import Data.List (foldl') import Network.HPACK.Types newtype DoubleHashMap a = DoubleHashMap (HashMap HeaderName (HashMap HeaderValue a)) deriving Show empty :: DoubleHashMap a empty = DoubleHashMap H.empty insert :: Ord a => Header -> a -> DoubleHashMap a -> DoubleHashMap a insert (k,v) p (DoubleHashMap m) = case H.lookup k m of Nothing -> let inner = H.singleton v p in DoubleHashMap $ H.insert k inner m Just inner -> let inner' = H.insert v p inner in DoubleHashMap $ H.adjust (const inner') k m delete :: Ord a => Header -> DoubleHashMap a -> DoubleHashMap a delete (k,v) dhm@(DoubleHashMap outer) = case H.lookup k outer of Nothing -> dhm -- Non-smart implementation makes duplicate keys. -- It is likely to happen to delete the same key -- in multiple times. Just inner -> case H.lookup v inner of Nothing -> dhm -- see above _ -> delete' inner where delete' inner | H.null inner' = DoubleHashMap $ H.delete k outer | otherwise = DoubleHashMap $ H.adjust (const inner') k outer where inner' = H.delete v inner fromList :: Ord a => [(a,Header)] -> DoubleHashMap a fromList alist = hashinner where ins !hp (!a,!dhm) = insert dhm a hp !hashinner = foldl' ins empty alist deleteList :: Ord a => [Header] -> DoubleHashMap a -> DoubleHashMap a deleteList hs hp = foldl' (flip delete) hp hs data Res a = N | K a | KV a search :: Ord a => Header -> DoubleHashMap a -> Res a search (k,v) (DoubleHashMap outer) = case H.lookup k outer of Nothing -> N Just inner -> case H.lookup v inner of Nothing -> case top inner of Nothing -> error "DoubleHashMap.search" Just a -> K a Just a -> KV a -- | Take an arbitrary entry. O(1) thanks to lazy evaluation. top :: HashMap k v -> Maybe v top = H.foldr (\v _ -> Just v) Nothing http2-1.3.1/Network/HPACK/Table/Dynamic.hs0000644000000000000000000002317112624764141016204 0ustar0000000000000000{-# LANGUAGE TupleSections, RecordWildCards, FlexibleContexts #-} module Network.HPACK.Table.Dynamic ( DynamicTable(..) , newDynamicTableForEncoding , newDynamicTableForDecoding , renewDynamicTable , printDynamicTable , isDynamicTableEmpty , isSuitableSize , TableSizeAction(..) , needChangeTableSize , setLimitForEncoding , resetLimitForEncoding , insertEntry , toHeaderEntry , fromHIndexToIndex , fromIndexToHIndex , fromSIndexToIndex , fromIndexToSIndex ) where import Control.Monad (forM) import Data.Array.IO (IOArray, newArray, readArray, writeArray) import qualified Data.ByteString.Char8 as BS import Data.IORef import qualified Network.HPACK.Table.DoubleHashMap as DHM import Network.HPACK.Table.Entry import Network.HPACK.Table.Static ---------------------------------------------------------------- type Table = IOArray Index Entry {- offset v +-+-+-+-+-+-+-+-+ | | | |z|y|x| | | +-+-+-+-+-+-+-+-+ 1 2 3 (numOfEntries = 3) After insertion: offset v +-+-+-+-+-+-+-+-+ | | |w|z|y|x| | | +-+-+-+-+-+-+-+-+ 1 2 3 4 (numOfEntries = 4) -} -- | Type for dynamic table. data DynamicTable = DynamicTable { -- | An array circularTable :: !Table -- | Start point , offset :: !Index -- | The current number of entries , numOfEntries :: !Int -- | The size of the array , maxNumOfEntries :: !Int -- | The current dynamic table size (defined in HPACK) , headerTableSize :: !Size -- | The max dynamic table size (defined in HPACK) , maxDynamicTableSize :: !Size -- | The value informed by SETTINGS_HEADER_TABLE_SIZE. -- If 'Nothing', dynamic table size update is not necessary. -- Otherwise, dynamic table size update is sent -- and this value should be set to 'Nothing'. , limitForEncoding :: IORef (Maybe Size) -- | The limit size of a dynamic table for decoding , limitForDecoding :: !Size -- | Header to the index in Dynamic Table for encoder. -- Static Table is not included. -- Nothing for decoder. , reverseIndex :: Maybe (DHM.DoubleHashMap HIndex) } adj :: Int -> Int -> Int adj maxN x = (x + maxN) `mod` maxN ---------------------------------------------------------------- -- | Printing 'DynamicTable'. printDynamicTable :: DynamicTable -> IO () printDynamicTable DynamicTable{..} = do es <- mapM (readArray circularTable . adj maxNumOfEntries) [beg .. end] let ts = zip [1..] es mapM_ printEntry ts putStrLn $ " Table size: " ++ show headerTableSize ++ "/" ++ show maxDynamicTableSize print reverseIndex where beg = offset + 1 end = offset + numOfEntries printEntry :: (Index,Entry) -> IO () printEntry (i,e) = do putStr "[ " putStr $ show i putStr "] (s = " putStr $ show $ entrySize e putStr ") " BS.putStr $ entryHeaderName e putStr ": " BS.putStrLn $ entryHeaderValue e ---------------------------------------------------------------- isDynamicTableEmpty :: DynamicTable -> Bool isDynamicTableEmpty dyntbl = numOfEntries dyntbl == 0 isSuitableSize :: Size -> DynamicTable -> Bool isSuitableSize siz tbl = siz <= limitForDecoding tbl data TableSizeAction = Keep | Change Size | Ignore Size needChangeTableSize :: DynamicTable -> IO TableSizeAction needChangeTableSize tbl = do mlim <- getLimitForEncoding tbl return $ case mlim of Nothing -> Keep Just lim | lim < maxsiz -> Change lim | otherwise -> Ignore maxsiz where maxsiz = maxDynamicTableSize tbl getLimitForEncoding :: DynamicTable -> IO (Maybe Size) getLimitForEncoding dyntbl = readIORef $ limitForEncoding dyntbl -- | When SETTINGS_HEADER_TABLE_SIZE is received from a peer, -- its value should be set by this function. setLimitForEncoding :: Size -> DynamicTable -> IO () setLimitForEncoding siz dyntbl = writeIORef (limitForEncoding dyntbl) $ Just siz resetLimitForEncoding :: DynamicTable -> IO () resetLimitForEncoding dyntbl = writeIORef (limitForEncoding dyntbl) Nothing ---------------------------------------------------------------- -- Physical array index for Dynamic Table. newtype HIndex = HIndex Int deriving (Eq, Ord, Show) ---------------------------------------------------------------- fromHIndexToIndex :: DynamicTable -> HIndex -> Index fromHIndexToIndex DynamicTable{..} (HIndex hidx) = idx where idx = adj maxNumOfEntries (hidx - offset) + staticTableSize fromIndexToHIndex :: DynamicTable -> Index -> HIndex fromIndexToHIndex DynamicTable{..} idx = HIndex hidx where hidx = adj maxNumOfEntries (idx + offset - staticTableSize) fromSIndexToIndex :: DynamicTable -> SIndex -> Index fromSIndexToIndex _ sidx = fromStaticIndex sidx fromIndexToSIndex :: DynamicTable -> Index -> SIndex fromIndexToSIndex _ idx = toStaticIndex idx ---------------------------------------------------------------- -- | Creating 'DynamicTable'. newDynamicTableForEncoding :: Size -> IO DynamicTable newDynamicTableForEncoding maxsiz = newDynamicTable maxsiz maxsiz (Just DHM.empty) -- | Creating 'DynamicTable'. newDynamicTableForDecoding :: Size -> IO DynamicTable newDynamicTableForDecoding maxsiz = newDynamicTable maxsiz maxsiz Nothing newDynamicTable :: Size -> Size -> Maybe (DHM.DoubleHashMap HIndex) -> IO DynamicTable newDynamicTable maxsiz dlim mhp = do tbl <- newArray (0,end) dummyEntry lim <- newIORef Nothing return DynamicTable { maxNumOfEntries = maxN , offset = end , numOfEntries = 0 , circularTable = tbl , headerTableSize = 0 , maxDynamicTableSize = maxsiz , limitForEncoding = lim , limitForDecoding = dlim , reverseIndex = mhp } where maxN = maxNumbers maxsiz end = maxN - 1 -- | Renewing 'DynamicTable' with necessary entries copied. renewDynamicTable :: Size -> DynamicTable -> IO DynamicTable renewDynamicTable maxsiz olddyntbl | shouldRenew olddyntbl maxsiz = newDynamicTable maxsiz dlim mhp >>= copyTable olddyntbl where dlim = limitForDecoding olddyntbl mhp = case reverseIndex olddyntbl of Nothing -> Nothing _ -> Just DHM.empty renewDynamicTable _ olddyntbl = return olddyntbl copyTable :: DynamicTable -> DynamicTable -> IO DynamicTable copyTable olddyntbl newdyntbl = getEntries olddyntbl >>= copyEntries newdyntbl getEntries :: DynamicTable -> IO [Entry] getEntries DynamicTable{..} = forM [1 .. numOfEntries] readTable where readTable i = readArray circularTable $ adj maxNumOfEntries (offset + i) copyEntries :: DynamicTable -> [Entry] -> IO DynamicTable copyEntries dyntbl [] = return dyntbl copyEntries dyntbl@DynamicTable{..} (e:es) | headerTableSize + entrySize e <= maxDynamicTableSize = do dyntbl' <- insertEnd e dyntbl copyEntries dyntbl' es | otherwise = return dyntbl -- | Is the size of 'DynamicTable' really changed? shouldRenew :: DynamicTable -> Size -> Bool shouldRenew DynamicTable{..} maxsiz = maxDynamicTableSize /= maxsiz ---------------------------------------------------------------- -- | Inserting 'Entry' to 'DynamicTable'. -- New 'DynamicTable', the largest new 'Index' -- and a set of dropped OLD 'Index' -- are returned. insertEntry :: Entry -> DynamicTable -> IO DynamicTable insertEntry e dyntbl = do (dyntbl', hs) <- insertFront e dyntbl >>= adjustTableSize let dyntbl'' = case reverseIndex dyntbl' of Nothing -> dyntbl' Just rev -> dyntbl' { reverseIndex = Just (DHM.deleteList hs rev) } return dyntbl'' insertFront :: Entry -> DynamicTable -> IO DynamicTable insertFront e dyntbl@DynamicTable{..} = do writeArray circularTable i e return $ dyntbl { offset = offset' , numOfEntries = numOfEntries + 1 , headerTableSize = headerTableSize' , reverseIndex = reverseIndex' } where i = offset headerTableSize' = headerTableSize + entrySize e offset' = adj maxNumOfEntries (offset - 1) reverseIndex' = case reverseIndex of Nothing -> Nothing Just rev -> Just $ DHM.insert (entryHeader e) (HIndex i) rev adjustTableSize :: DynamicTable -> IO (DynamicTable, [Header]) adjustTableSize dyntbl = adjust dyntbl [] adjust :: DynamicTable -> [Header] -> IO (DynamicTable, [Header]) adjust dyntbl@DynamicTable{..} hs | headerTableSize <= maxDynamicTableSize = return (dyntbl, hs) | otherwise = do (dyntbl', h) <- removeEnd dyntbl adjust dyntbl' (h:hs) ---------------------------------------------------------------- insertEnd :: Entry -> DynamicTable -> IO DynamicTable insertEnd e dyntbl@DynamicTable{..} = do writeArray circularTable i e return $ dyntbl { numOfEntries = numOfEntries + 1 , headerTableSize = headerTableSize' , reverseIndex = reverseIndex' } where i = adj maxNumOfEntries (offset + numOfEntries + 1) headerTableSize' = headerTableSize + entrySize e reverseIndex' = case reverseIndex of Nothing -> Nothing Just rev -> Just $ DHM.insert (entryHeader e) (HIndex i) rev ---------------------------------------------------------------- removeEnd :: DynamicTable -> IO (DynamicTable,Header) removeEnd dyntbl@DynamicTable{..} = do let i = adj maxNumOfEntries (offset + numOfEntries) e <- readArray circularTable i writeArray circularTable i dummyEntry -- let the entry GCed let tsize = headerTableSize - entrySize e h = entryHeader e dyntbl' = dyntbl { numOfEntries = numOfEntries - 1 , headerTableSize = tsize } return (dyntbl', h) ---------------------------------------------------------------- toHeaderEntry :: DynamicTable -> HIndex -> IO Entry toHeaderEntry DynamicTable{..} (HIndex hidx) = readArray circularTable hidx http2-1.3.1/Network/HPACK/Table/Entry.hs0000644000000000000000000000363212624764141015721 0ustar0000000000000000{-# LANGUAGE BangPatterns, OverloadedStrings #-} module Network.HPACK.Table.Entry ( -- * Type Size , Entry , Header -- re-exporting , HeaderName -- re-exporting , HeaderValue -- re-exporting , Index -- re-exporting -- * Header and Entry , toEntry , fromEntry -- * Getters , entrySize , entryHeader , entryHeaderName , entryHeaderValue -- * For initialization , dummyEntry , maxNumbers ) where import qualified Data.ByteString as BS import Network.HPACK.Types ---------------------------------------------------------------- -- | Size in bytes. type Size = Int -- | Type for table entry. Size includes the 32 bytes magic number. type Entry = (Size,Header) ---------------------------------------------------------------- headerSizeMagicNumber :: Size headerSizeMagicNumber = 32 headerSize :: Header -> Size headerSize (k,v) = BS.length k + BS.length v + headerSizeMagicNumber ---------------------------------------------------------------- -- | From 'Header' to 'Entry'. toEntry :: Header -> Entry toEntry h = (siz,h) where !siz = headerSize h -- | From 'Entry' to 'Header'. fromEntry :: Entry -> Header fromEntry = snd ---------------------------------------------------------------- -- | Getting the size of 'Entry'. entrySize :: Entry -> Size entrySize = fst -- | Getting 'Header'. entryHeader :: Entry -> Header entryHeader (_,h) = h -- | Getting 'HeaderName'. entryHeaderName :: Entry -> HeaderName entryHeaderName (_,(k,_)) = k -- | Getting 'HeaderValue'. entryHeaderValue :: Entry -> HeaderValue entryHeaderValue (_,(_,v)) = v ---------------------------------------------------------------- -- | Dummy 'Entry' to initialize a dynamic table. dummyEntry :: Entry dummyEntry = (0,("dummy","dummy")) -- | How many entries can be stored in a dynamic table? maxNumbers :: Size -> Int maxNumbers siz = siz `div` headerSizeMagicNumber http2-1.3.1/Network/HPACK/Table/Static.hs0000644000000000000000000000574412624764141016055 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.HPACK.Table.Static ( SIndex(..) , fromStaticIndex , toStaticIndex , isSIndexValid , toStaticEntry , staticHashMap , staticTableSize -- fixme ) where import Data.Array (Array, listArray, (!)) import Network.HPACK.Table.Entry import qualified Network.HPACK.Table.DoubleHashMap as DHM ---------------------------------------------------------------- newtype SIndex = SIndex Int deriving (Eq,Ord,Show) fromStaticIndex :: SIndex -> Int fromStaticIndex (SIndex sidx) = sidx toStaticIndex :: Int -> SIndex toStaticIndex = SIndex isSIndexValid :: SIndex -> Bool isSIndexValid (SIndex sidx) = 1 <= sidx && sidx <= staticTableSize ---------------------------------------------------------------- -- | The size of static table. staticTableSize :: Size staticTableSize = length staticTableList -- | Get 'Entry' from the static table. -- -- >>> toStaticEntry (SIndex 1) -- (42,(":authority","")) -- >>> toStaticEntry (SIndex 8) -- (42,(":status","200")) -- >>> toStaticEntry (SIndex 50) -- (37,("range","")) toStaticEntry :: SIndex -> Entry toStaticEntry (SIndex sidx) = staticTable ! sidx -- | Pre-defined static table. staticTable :: Array Index Entry staticTable = listArray (1,staticTableSize) $ map toEntry staticTableList staticHashMap :: DHM.DoubleHashMap SIndex staticHashMap = DHM.fromList alist where is = map toStaticIndex [1..] alist = zip is staticTableList ---------------------------------------------------------------- staticTableList :: [Header] staticTableList = [ (":authority", "") , (":method", "GET") , (":method", "POST") , (":path", "/") , (":path", "/index.html") , (":scheme", "http") , (":scheme", "https") , (":status", "200") , (":status", "204") , (":status", "206") , (":status", "304") , (":status", "400") , (":status", "404") , (":status", "500") , ("accept-charset", "") , ("accept-encoding", "gzip, deflate") , ("accept-language", "") , ("accept-ranges", "") , ("accept", "") , ("access-control-allow-origin", "") , ("age", "") , ("allow", "") , ("authorization", "") , ("cache-control", "") , ("content-disposition", "") , ("content-encoding", "") , ("content-language", "") , ("content-length", "") , ("content-location", "") , ("content-range", "") , ("content-type", "") , ("cookie", "") , ("date", "") , ("etag", "") , ("expect", "") , ("expires", "") , ("from", "") , ("host", "") , ("if-match", "") , ("if-modified-since", "") , ("if-none-match", "") , ("if-range", "") , ("if-unmodified-since", "") , ("last-modified", "") , ("link", "") , ("location", "") , ("max-forwards", "") , ("proxy-authenticate", "") , ("proxy-authorization", "") , ("range", "") , ("referer", "") , ("refresh", "") , ("retry-after", "") , ("server", "") , ("set-cookie", "") , ("strict-transport-security", "") , ("transfer-encoding", "") , ("user-agent", "") , ("vary", "") , ("via", "") , ("www-authenticate", "") ] http2-1.3.1/Network/HTTP2/0000755000000000000000000000000012624764141013244 5ustar0000000000000000http2-1.3.1/Network/HTTP2/Decode.hs0000644000000000000000000002572712624764141015000 0ustar0000000000000000{-# LANGUAGE TupleSections, BangPatterns, RecordWildCards, OverloadedStrings #-} {-# LANGUAGE CPP #-} module Network.HTTP2.Decode ( -- * Decoding decodeFrame , decodeFrameHeader , checkFrameHeader -- * Decoding payload , decodeFramePayload , FramePayloadDecoder , decodeDataFrame , decodeHeadersFrame , decodePriorityFrame , decoderstStreamFrame , decodeSettingsFrame , decodePushPromiseFrame , decodePingFrame , decodeGoAwayFrame , decodeWindowUpdateFrame , decodeContinuationFrame ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif import Data.Array (Array, listArray, (!)) import Data.Bits (clearBit, shiftL, (.|.)) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.ByteString.Internal (ByteString(..)) import Data.Word import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (Ptr, plusPtr) import Foreign.Storable (peek) import System.IO.Unsafe (unsafeDupablePerformIO) import Network.HTTP2.Types ---------------------------------------------------------------- -- | Decoding an HTTP/2 frame to 'ByteString'. -- The second argument must be include the entire of frame. -- So, this function is not useful for real applications -- but useful for testing. decodeFrame :: Settings -- ^ HTTP/2 settings -> ByteString -- ^ Input byte-stream -> Either HTTP2Error Frame -- ^ Decoded frame decodeFrame settings bs = checkFrameHeader settings (decodeFrameHeader bs0) >>= \(typ,header) -> decodeFramePayload typ header bs1 >>= \payload -> return $ Frame header payload where (bs0,bs1) = BS.splitAt 9 bs ---------------------------------------------------------------- -- | Decoding an HTTP/2 frame header. -- Must supply 9 bytes. decodeFrameHeader :: ByteString -> (FrameTypeId, FrameHeader) decodeFrameHeader (PS fptr off _) = unsafeDupablePerformIO $ withForeignPtr fptr $ \ptr -> do let p = ptr +. off l0 <- fromIntegral <$> peek p l1 <- fromIntegral <$> peek (p +. 1) l2 <- fromIntegral <$> peek (p +. 2) typ <- toFrameTypeId <$> peek (p +. 3) flg <- peek (p +. 4) w32 <- word32' (p +. 5) let !len = (l0 `shiftL` 16) .|. (l1 `shiftL` 8) .|. l2 !sid = streamIdentifier w32 return (typ, FrameHeader len flg sid) (+.) :: Ptr Word8 -> Int -> Ptr Word8 (+.) = plusPtr ---------------------------------------------------------------- -- | Checking a frame header and reporting an error if any. -- -- >>> checkFrameHeader defaultSettings (FrameData,(FrameHeader 100 0 0)) -- Left (ConnectionError ProtocolError "cannot used in control stream") checkFrameHeader :: Settings -> (FrameTypeId, FrameHeader) -> Either HTTP2Error (FrameTypeId, FrameHeader) checkFrameHeader Settings {..} typfrm@(typ,FrameHeader {..}) | payloadLength > maxFrameSize = Left $ ConnectionError FrameSizeError "exceeds maximum frame size" | typ `elem` nonZeroFrameTypes && isControl streamId = Left $ ConnectionError ProtocolError "cannot used in control stream" | typ `elem` zeroFrameTypes && not (isControl streamId) = Left $ ConnectionError ProtocolError "cannot used in non-zero stream" | otherwise = checkType typ where checkType FramePriority | payloadLength /= 5 = Left $ StreamError FrameSizeError streamId checkType FrameRSTStream | payloadLength /= 4 = Left $ ConnectionError FrameSizeError "payload length is not 4 in rst stream frame" checkType FrameSettings | payloadLength `mod` 6 /= 0 = Left $ ConnectionError FrameSizeError "payload length is not multiple of 6 in settings frame" | testAck flags && payloadLength /= 0 = Left $ ConnectionError FrameSizeError "payload length must be 0 if ack flag is set" checkType FramePushPromise | not enablePush = Left $ ConnectionError ProtocolError "push not enabled" -- checkme | not (isResponse streamId) = Left $ ConnectionError ProtocolError "push promise must be used with even stream identifier" checkType FramePing | payloadLength /= 8 = Left $ ConnectionError FrameSizeError "payload length is 8 in ping frame" checkType FrameGoAway | payloadLength < 8 = Left $ ConnectionError FrameSizeError "goaway body must be 8 bytes or larger" checkType FrameWindowUpdate | payloadLength /= 4 = Left $ ConnectionError FrameSizeError "payload length is 4 in window update frame" checkType _ = Right typfrm zeroFrameTypes :: [FrameTypeId] zeroFrameTypes = [ FrameSettings , FramePing , FrameGoAway ] nonZeroFrameTypes :: [FrameTypeId] nonZeroFrameTypes = [ FrameData , FrameHeaders , FramePriority , FrameRSTStream , FramePushPromise , FrameContinuation ] ---------------------------------------------------------------- -- | The type for frame payload decoder. type FramePayloadDecoder = FrameHeader -> ByteString -> Either HTTP2Error FramePayload payloadDecoders :: Array Word8 FramePayloadDecoder payloadDecoders = listArray (minFrameType, maxFrameType) [ decodeDataFrame , decodeHeadersFrame , decodePriorityFrame , decoderstStreamFrame , decodeSettingsFrame , decodePushPromiseFrame , decodePingFrame , decodeGoAwayFrame , decodeWindowUpdateFrame , decodeContinuationFrame ] -- | Decoding an HTTP/2 frame payload. -- This function is considered to return a frame payload decoder -- according to a frame type. decodeFramePayload :: FrameTypeId -> FramePayloadDecoder decodeFramePayload (FrameUnknown typ) = checkFrameSize $ decodeUnknownFrame typ decodeFramePayload ftyp = checkFrameSize decoder where decoder = payloadDecoders ! fromFrameTypeId ftyp ---------------------------------------------------------------- -- | Frame payload decoder for DATA frame. decodeDataFrame :: FramePayloadDecoder decodeDataFrame header bs = decodeWithPadding header bs DataFrame -- | Frame payload decoder for HEADERS frame. decodeHeadersFrame :: FramePayloadDecoder decodeHeadersFrame header bs = decodeWithPadding header bs $ \bs' -> if hasPriority then let (bs0,bs1) = BS.splitAt 5 bs' p = priority bs0 in HeadersFrame (Just p) bs1 else HeadersFrame Nothing bs' where hasPriority = testPriority $ flags header -- | Frame payload decoder for PRIORITY frame. decodePriorityFrame :: FramePayloadDecoder decodePriorityFrame _ bs = Right $ PriorityFrame $ priority bs -- | Frame payload decoder for RST_STREAM frame. decoderstStreamFrame :: FramePayloadDecoder decoderstStreamFrame _ bs = Right $ RSTStreamFrame $ toErrorCodeId (word32 bs) -- | Frame payload decoder for SETTINGS frame. decodeSettingsFrame :: FramePayloadDecoder decodeSettingsFrame FrameHeader{..} (PS fptr off _) = Right $ SettingsFrame alist where num = payloadLength `div` 6 alist = unsafeDupablePerformIO $ withForeignPtr fptr $ \ptr -> do let p = ptr +. off settings num p id settings 0 _ builder = return $ builder [] settings n p builder = do rawSetting <- word16' p let msettings = toSettingsKeyId rawSetting n' = n - 1 case msettings of Nothing -> settings n' (p +. 6) builder -- ignoring unknown one (Section 6.5.2) Just k -> do w32 <- word32' (p +. 2) let v = fromIntegral w32 settings n' (p +. 6) (builder. ((k,v):)) -- | Frame payload decoder for PUSH_PROMISE frame. decodePushPromiseFrame :: FramePayloadDecoder decodePushPromiseFrame header bs = decodeWithPadding header bs $ \bs' -> let (bs0,bs1) = BS.splitAt 4 bs' sid = streamIdentifier (word32 bs0) in PushPromiseFrame sid bs1 -- | Frame payload decoder for PING frame. decodePingFrame :: FramePayloadDecoder decodePingFrame _ bs = Right $ PingFrame bs -- | Frame payload decoder for GOAWAY frame. decodeGoAwayFrame :: FramePayloadDecoder decodeGoAwayFrame _ bs = Right $ GoAwayFrame sid ecid bs2 where (bs0,bs1') = BS.splitAt 4 bs (bs1,bs2) = BS.splitAt 4 bs1' sid = streamIdentifier (word32 bs0) ecid = toErrorCodeId (word32 bs1) -- | Frame payload decoder for WINDOW_UPDATE frame. decodeWindowUpdateFrame :: FramePayloadDecoder decodeWindowUpdateFrame _ bs | wsi == 0 = Left $ ConnectionError ProtocolError "window update must not be 0" | otherwise = Right $ WindowUpdateFrame wsi where !wsi = fromIntegral (word32 bs `clearBit` 31) -- | Frame payload decoder for CONTINUATION frame. decodeContinuationFrame :: FramePayloadDecoder decodeContinuationFrame _ bs = Right $ ContinuationFrame bs decodeUnknownFrame :: FrameType -> FramePayloadDecoder decodeUnknownFrame typ _ bs = Right $ UnknownFrame typ bs ---------------------------------------------------------------- checkFrameSize :: FramePayloadDecoder -> FramePayloadDecoder checkFrameSize func header@FrameHeader{..} body | payloadLength > BS.length body = Left $ ConnectionError FrameSizeError "payload is too short" | otherwise = func header body -- | Helper function to pull off the padding if its there, and will -- eat up the trailing padding automatically. Calls the decoder func -- passed in with the length of the unpadded portion between the -- padding octet and the actual padding decodeWithPadding :: FrameHeader -> ByteString -> (ByteString -> FramePayload) -> Either HTTP2Error FramePayload decodeWithPadding FrameHeader{..} bs body | padded = let Just (w8,rest) = BS.uncons bs padlen = intFromWord8 w8 bodylen = payloadLength - padlen - 1 in if bodylen < 0 then Left $ ConnectionError ProtocolError "padding is not enough" else Right . body $ BS.take bodylen rest | otherwise = Right $ body bs where padded = testPadded flags streamIdentifier :: Word32 -> StreamId streamIdentifier w32 = clearExclusive $ fromIntegral w32 priority :: ByteString -> Priority priority (PS fptr off _) = unsafeDupablePerformIO $ withForeignPtr fptr $ \ptr -> do let p = ptr +. off w32 <- word32' p let !streamdId = streamIdentifier w32 !exclusive = testExclusive (fromIntegral w32) -- fixme w8 <- peek (p +. 4) let weight = intFromWord8 w8 + 1 return $ Priority exclusive streamdId weight intFromWord8 :: Word8 -> Int intFromWord8 = fromIntegral word32 :: ByteString -> Word32 word32 (PS fptr off _) = unsafeDupablePerformIO $ withForeignPtr fptr $ \ptr -> do let p = ptr +. off word32' p {-# INLINE word32 #-} word32' :: Ptr Word8 -> IO Word32 word32' p = do w0 <- fromIntegral <$> peek p w1 <- fromIntegral <$> peek (p +. 1) w2 <- fromIntegral <$> peek (p +. 2) w3 <- fromIntegral <$> peek (p +. 3) let !w32 = (w0 `shiftL` 24) .|. (w1 `shiftL` 16) .|. (w2 `shiftL` 8) .|. w3 return w32 {-# INLINE word32' #-} word16' :: Ptr Word8 -> IO Word16 word16' p = do w0 <- fromIntegral <$> peek p w1 <- fromIntegral <$> peek (p +. 1) let !w16 = (w0 `shiftL` 8) .|. w1 return w16 {-# INLINE word16' #-} http2-1.3.1/Network/HTTP2/Encode.hs0000644000000000000000000002334012624764141014777 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} module Network.HTTP2.Encode ( encodeFrame , encodeFrameChunks , encodeFrameHeader , encodeFrameHeaderBuf , encodeFramePayload , EncodeInfo(..) , encodeInfo ) where import Data.Bits (shiftR, (.&.)) import qualified Data.ByteString as BS import Data.ByteString.Internal (ByteString, unsafeCreate) import Data.Word (Word8, Word16, Word32) import Foreign.Ptr (Ptr, plusPtr) import Foreign.Storable (poke) import Network.HTTP2.Types ---------------------------------------------------------------- type Builder = [ByteString] -> [ByteString] -- | Auxiliary information for frame encoding. data EncodeInfo = EncodeInfo { -- | Flags to be set in a frame header encodeFlags :: FrameFlags -- | Stream id to be set in a frame header , encodeStreamId :: StreamId -- | Padding if any. In the case where this value is set but the priority flag is not set, this value gets preference over the priority flag. So, if this value is set, the priority flag is also set. , encodePadding :: Maybe Padding } deriving (Show,Read) ---------------------------------------------------------------- -- | A smart builder of 'EncodeInfo'. -- -- >>> encodeInfo setAck 0 -- EncodeInfo {encodeFlags = 1, encodeStreamId = 0, encodePadding = Nothing} encodeInfo :: (FrameFlags -> FrameFlags) -> Int -- ^ stream identifier -> EncodeInfo encodeInfo set sid = EncodeInfo (set defaultFlags) sid Nothing ---------------------------------------------------------------- -- | Encoding an HTTP/2 frame to 'ByteString'. -- This function is not efficient enough for high performace -- program because of the concatenation of 'ByteString'. -- -- >>> encodeFrame (encodeInfo id 1) (DataFrame "body") -- "\NUL\NUL\EOT\NUL\NUL\NUL\NUL\NUL\SOHbody" encodeFrame :: EncodeInfo -> FramePayload -> ByteString encodeFrame einfo payload = BS.concat $ encodeFrameChunks einfo payload -- | Encoding an HTTP/2 frame to ['ByteString']. -- This is suitable for sendMany. encodeFrameChunks :: EncodeInfo -> FramePayload -> [ByteString] encodeFrameChunks einfo payload = bs : bss where ftid = framePayloadToFrameTypeId payload bs = encodeFrameHeader ftid header (header, bss) = encodeFramePayload einfo payload -- | Encoding an HTTP/2 frame header. -- The frame header must be completed. encodeFrameHeader :: FrameTypeId -> FrameHeader -> ByteString encodeFrameHeader ftid fhdr = unsafeCreate frameHeaderLength $ encodeFrameHeaderBuf ftid fhdr -- | Writing an encoded HTTP/2 frame header to the buffer. -- The length of the buffer must be larger than or equal to 9 bytes. encodeFrameHeaderBuf :: FrameTypeId -> FrameHeader -> Ptr Word8 -> IO () encodeFrameHeaderBuf ftid FrameHeader{..} ptr = do poke24 ptr payloadLength poke8 ptr 3 typ poke8 ptr 4 flags poke32 (ptr `plusPtr` 5) sid where typ = fromFrameTypeId ftid sid = fromIntegral streamId -- | Encoding an HTTP/2 frame payload. -- This returns a complete frame header and chunks of payload. encodeFramePayload :: EncodeInfo -> FramePayload -> (FrameHeader, [ByteString]) encodeFramePayload einfo payload = (header, builder []) where (header, builder) = buildFramePayload einfo payload ---------------------------------------------------------------- buildFramePayload :: EncodeInfo -> FramePayload -> (FrameHeader, Builder) buildFramePayload einfo (DataFrame body) = buildFramePayloadData einfo body buildFramePayload einfo (HeadersFrame mpri hdr) = buildFramePayloadHeaders einfo mpri hdr buildFramePayload einfo (PriorityFrame pri) = buildFramePayloadPriority einfo pri buildFramePayload einfo (RSTStreamFrame e) = buildFramePayloadRSTStream einfo e buildFramePayload einfo (SettingsFrame settings) = buildFramePayloadSettings einfo settings buildFramePayload einfo (PushPromiseFrame sid hdr) = buildFramePayloadPushPromise einfo sid hdr buildFramePayload einfo (PingFrame opaque) = buildFramePayloadPing einfo opaque buildFramePayload einfo (GoAwayFrame sid e debug) = buildFramePayloadGoAway einfo sid e debug buildFramePayload einfo (WindowUpdateFrame size) = buildFramePayloadWindowUpdate einfo size buildFramePayload einfo (ContinuationFrame hdr) = buildFramePayloadContinuation einfo hdr buildFramePayload einfo (UnknownFrame _ opaque) = buildFramePayloadUnknown einfo opaque ---------------------------------------------------------------- buildPadding :: EncodeInfo -> Builder -> Int -- ^ Payload length. -> (FrameHeader, Builder) buildPadding EncodeInfo{ encodePadding = Nothing, ..} builder len = (header, builder) where header = FrameHeader len encodeFlags encodeStreamId buildPadding EncodeInfo{ encodePadding = Just padding, ..} btarget targetLength = (header, builder) where header = FrameHeader len newflags encodeStreamId builder = (b1 :) . btarget . (padding :) b1 = BS.singleton $ fromIntegral paddingLength paddingLength = BS.length padding len = targetLength + paddingLength + 1 newflags = setPadded encodeFlags buildPriority :: Priority -> Builder buildPriority Priority{..} = builder where builder = (priority :) estream | exclusive = setExclusive streamDependency | otherwise = streamDependency priority = unsafeCreate 5 $ \ptr -> do poke32 ptr $ fromIntegral estream poke8 ptr 4 $ fromIntegral $ weight - 1 ---------------------------------------------------------------- buildFramePayloadData :: EncodeInfo -> ByteString -> (FrameHeader, Builder) buildFramePayloadData einfo body = buildPadding einfo builder len where builder = (body :) len = BS.length body buildFramePayloadHeaders :: EncodeInfo -> Maybe Priority -> HeaderBlockFragment -> (FrameHeader, Builder) buildFramePayloadHeaders einfo Nothing hdr = buildPadding einfo builder len where builder = (hdr :) len = BS.length hdr buildFramePayloadHeaders einfo (Just pri) hdr = buildPadding einfo' builder len where builder = buildPriority pri . (hdr :) len = BS.length hdr + 5 einfo' = einfo { encodeFlags = setPriority (encodeFlags einfo) } buildFramePayloadPriority :: EncodeInfo -> Priority -> (FrameHeader, Builder) buildFramePayloadPriority EncodeInfo{..} p = (header, builder) where builder = buildPriority p header = FrameHeader 5 encodeFlags encodeStreamId buildFramePayloadRSTStream :: EncodeInfo -> ErrorCodeId -> (FrameHeader, Builder) buildFramePayloadRSTStream EncodeInfo{..} e = (header, builder) where builder = (b4 :) b4 = bytestring4 $ fromErrorCodeId e header = FrameHeader 4 encodeFlags encodeStreamId buildFramePayloadSettings :: EncodeInfo -> SettingsList -> (FrameHeader, Builder) buildFramePayloadSettings EncodeInfo{..} alist = (header, builder) where builder = (settings :) settings = unsafeCreate len $ \ptr -> go ptr alist go _ [] = return () go p ((k,v):kvs) = do poke16 p $ fromSettingsKeyId k poke32 (p `plusPtr` 2) $ fromIntegral v go (p `plusPtr` 6) kvs len = length alist * 6 header = FrameHeader len encodeFlags encodeStreamId buildFramePayloadPushPromise :: EncodeInfo -> StreamId -> HeaderBlockFragment -> (FrameHeader, Builder) buildFramePayloadPushPromise einfo sid hdr = buildPadding einfo builder len where builder = (b4 :) . (hdr :) b4 = bytestring4 $ fromIntegral sid len = 4 + BS.length hdr buildFramePayloadPing :: EncodeInfo -> ByteString -> (FrameHeader, Builder) buildFramePayloadPing EncodeInfo{..} odata = (header, builder) where builder = (odata :) header = FrameHeader 8 encodeFlags encodeStreamId buildFramePayloadGoAway :: EncodeInfo -> StreamId -> ErrorCodeId -> ByteString -> (FrameHeader, Builder) buildFramePayloadGoAway EncodeInfo{..} sid e debug = (header, builder) where builder = (b8 :) . (debug :) len0 = 8 b8 = unsafeCreate len0 $ \ptr -> do poke32 ptr $ fromIntegral sid poke32 (ptr `plusPtr` 4) $ fromErrorCodeId e len = len0 + BS.length debug header = FrameHeader len encodeFlags encodeStreamId buildFramePayloadWindowUpdate :: EncodeInfo -> WindowSize -> (FrameHeader, Builder) buildFramePayloadWindowUpdate EncodeInfo{..} size = (header, builder) where -- fixme: reserve bit builder = (b4 :) b4 = bytestring4 $ fromIntegral size header = FrameHeader 4 encodeFlags encodeStreamId buildFramePayloadContinuation :: EncodeInfo -> HeaderBlockFragment -> (FrameHeader, Builder) buildFramePayloadContinuation EncodeInfo{..} hdr = (header, builder) where builder = (hdr :) len = BS.length hdr header = FrameHeader len encodeFlags encodeStreamId buildFramePayloadUnknown :: EncodeInfo -> ByteString -> (FrameHeader, Builder) buildFramePayloadUnknown = buildFramePayloadData ---------------------------------------------------------------- poke8 :: Ptr Word8 -> Int -> Word8 -> IO () poke8 ptr n w = poke (ptr `plusPtr` n) w poke16 :: Ptr Word8 -> Word16 -> IO () poke16 ptr i = do poke ptr w0 poke8 ptr 1 w1 where w0 = fromIntegral ((i `shiftR` 8) .&. 0xff) w1 = fromIntegral (i .&. 0xff) poke24 :: Ptr Word8 -> Int -> IO () poke24 ptr i = do poke ptr w0 poke8 ptr 1 w1 poke8 ptr 2 w2 where w0 = fromIntegral ((i `shiftR` 16) .&. 0xff) w1 = fromIntegral ((i `shiftR` 8) .&. 0xff) w2 = fromIntegral (i .&. 0xff) poke32 :: Ptr Word8 -> Word32 -> IO () poke32 ptr i = do poke ptr w0 poke8 ptr 1 w1 poke8 ptr 2 w2 poke8 ptr 3 w3 where w0 = fromIntegral ((i `shiftR` 24) .&. 0xff) w1 = fromIntegral ((i `shiftR` 16) .&. 0xff) w2 = fromIntegral ((i `shiftR` 8) .&. 0xff) w3 = fromIntegral (i .&. 0xff) bytestring4 :: Word32 -> ByteString bytestring4 i = unsafeCreate 4 $ \ptr -> poke32 ptr i http2-1.3.1/Network/HTTP2/Priority.hs0000644000000000000000000001171312624764141015424 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} -- | This is partial implementation of the priority of HTTP/2. -- -- This implementation does support structured priority queue -- but not support re-structuring. This means that it is assumed that -- an entry created by a Priority frame is never closed. The entry -- behaves an intermediate node, not a leaf. -- -- This queue is fair for weight. Consider two weights: 201 and 101. -- Repeating enqueue/dequeue probably produces -- 201, 201, 101, 201, 201, 101, ... -- -- Only one entry per stream should be enqueued. module Network.HTTP2.Priority ( -- * Precedence Precedence , defaultPrecedence , toPrecedence -- * PriorityTree , PriorityTree , newPriorityTree -- * PriorityTree functions , prepare , enqueue , enqueueControl , dequeue , delete ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Control.Concurrent.STM import Control.Monad (when, unless) import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as Map import Network.HTTP2.Priority.Queue (TPriorityQueue, Precedence) import qualified Network.HTTP2.Priority.Queue as Q import Network.HTTP2.Types ---------------------------------------------------------------- -- | Abstract data type for priority trees. data PriorityTree a = PriorityTree (TVar (Glue a)) (TNestedPriorityQueue a) (TQueue (StreamId, Precedence, a)) type Glue a = IntMap (TNestedPriorityQueue a, Precedence) -- INVARIANT: Empty TNestedPriorityQueue is never enqueued in -- another TNestedPriorityQueue. type TNestedPriorityQueue a = TPriorityQueue (Element a) data Element a = Child a | Parent (TNestedPriorityQueue a) ---------------------------------------------------------------- -- | Default precedence. defaultPrecedence :: Precedence defaultPrecedence = toPrecedence defaultPriority -- | Converting 'Priority' to 'Precedence'. -- When an entry is enqueued at the first time, -- this function should be used. toPrecedence :: Priority -> Precedence toPrecedence (Priority _ dep w) = Q.Precedence 0 w dep ---------------------------------------------------------------- -- | Creating a new priority tree. newPriorityTree :: IO (PriorityTree a) newPriorityTree = PriorityTree <$> newTVarIO Map.empty <*> atomically Q.new <*> newTQueueIO ---------------------------------------------------------------- -- | Bringing up the structure of the priority tree. -- This must be used for Priority frame. prepare :: PriorityTree a -> StreamId -> Priority -> IO () prepare (PriorityTree var _ _) sid p = atomically $ do q <- Q.new let pre = toPrecedence p modifyTVar' var $ Map.insert sid (q, pre) -- | Enqueuing an entry to the priority tree. -- This must be used for Header frame. enqueue :: PriorityTree a -> StreamId -> Precedence -> a -> IO () enqueue (PriorityTree var q0 _) sid p0 x = atomically $ do m <- readTVar var let !el = Child x loop m el p0 where loop m el p | pid == 0 = Q.enqueue q0 sid p el | otherwise = case Map.lookup pid m of -- If not found, enqueuing it to the stream 0 queue. Nothing -> Q.enqueue q0 sid p el Just (q', p') -> do notQueued <- Q.isEmpty q' Q.enqueue q' sid p el when notQueued $ do let !el' = Parent q' loop m el' p' where pid = Q.dependency p -- | Putting an entry to the top of the priority tree. enqueueControl :: PriorityTree a -> StreamId -> a -> IO () enqueueControl (PriorityTree _ _ cq) sid x = atomically $ writeTQueue cq (sid,defaultPrecedence,x) -- | Dequeuing an entry from the priority tree. dequeue :: PriorityTree a -> IO (StreamId, Precedence, a) dequeue (PriorityTree _ q0 cq) = atomically $ do mx <- tryReadTQueue cq case mx of Just x -> return x Nothing -> loop q0 where loop q = do (sid,p,el) <- Q.dequeue q case el of Child x -> return $! (sid, p, x) Parent q' -> do entr <- loop q' empty <- Q.isEmpty q' unless empty $ Q.enqueue q sid p el return entr -- | Deleting the entry corresponding to 'StreamId'. -- 'delete' and 'enqueue' are used to change the priority of -- a live stream. delete :: PriorityTree a -> StreamId -> Precedence -> IO (Maybe a) delete (PriorityTree var q0 _) sid p | pid == 0 = atomically $ del q0 | otherwise = atomically $ do m <- readTVar var case Map.lookup pid m of Nothing -> return Nothing Just (q,_) -> del q where pid = Q.dependency p del q = do mel <- Q.delete sid q case mel of Nothing -> return Nothing Just el -> case el of Child x -> return $ Just x Parent _ -> return Nothing -- fixme: this is error http2-1.3.1/Network/HTTP2/Types.hs0000644000000000000000000004312012624764141014704 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} module Network.HTTP2.Types ( -- * Constant frameHeaderLength , maxPayloadLength -- * SettingsList , SettingsKeyId(..) , checkSettingsList , fromSettingsKeyId , SettingsValue , SettingsList , toSettingsKeyId -- * Settings , Settings(..) , defaultSettings , updateSettings -- * Error , HTTP2Error(..) , errorCodeId -- * Error code , ErrorCode , ErrorCodeId(..) , fromErrorCodeId , toErrorCodeId -- * Frame type , FrameType , minFrameType , maxFrameType , FrameTypeId(..) , fromFrameTypeId , toFrameTypeId -- * Frame , Frame(..) , FrameHeader(..) , FramePayload(..) , framePayloadToFrameTypeId , isPaddingDefined -- * Stream identifier , StreamId , isControl , isRequest , isResponse , testExclusive , setExclusive , clearExclusive -- * Flags , FrameFlags , defaultFlags , testEndStream , testAck , testEndHeader , testPadded , testPriority , setEndStream , setAck , setEndHeader , setPadded , setPriority -- * Window , WindowSize , defaultInitialWindowSize , maxWindowSize , isWindowOverflow -- * Misc , recommendedConcurrency -- * Types , HeaderBlockFragment , Weight , Priority(..) , defaultPriority , highestPriority , Padding ) where import qualified Control.Exception as E import Data.Bits (setBit, testBit, clearBit) import Data.ByteString (ByteString) import Data.Maybe (mapMaybe) import Data.Typeable import Data.Word (Word8, Word16, Word32) ---------------------------------------------------------------- -- | The length of HTTP/2 frame header. -- -- >>> frameHeaderLength -- 9 frameHeaderLength :: Int frameHeaderLength = 9 ---------------------------------------------------------------- -- | The type for raw error code. type ErrorCode = Word32 -- | The type for error code. See . data ErrorCodeId = NoError | ProtocolError | InternalError | FlowControlError | SettingsTimeout | StreamClosed | FrameSizeError | RefusedStream | Cancel | CompressionError | ConnectError | EnhanceYourCalm | InadequateSecurity | HTTP11Required -- our extensions | UnknownErrorCode ErrorCode deriving (Show, Read, Eq, Ord) -- | Converting 'ErrorCodeId' to 'ErrorCode'. -- -- >>> fromErrorCodeId NoError -- 0 -- >>> fromErrorCodeId InadequateSecurity -- 12 fromErrorCodeId :: ErrorCodeId -> ErrorCode fromErrorCodeId NoError = 0x0 fromErrorCodeId ProtocolError = 0x1 fromErrorCodeId InternalError = 0x2 fromErrorCodeId FlowControlError = 0x3 fromErrorCodeId SettingsTimeout = 0x4 fromErrorCodeId StreamClosed = 0x5 fromErrorCodeId FrameSizeError = 0x6 fromErrorCodeId RefusedStream = 0x7 fromErrorCodeId Cancel = 0x8 fromErrorCodeId CompressionError = 0x9 fromErrorCodeId ConnectError = 0xa fromErrorCodeId EnhanceYourCalm = 0xb fromErrorCodeId InadequateSecurity = 0xc fromErrorCodeId HTTP11Required = 0xd fromErrorCodeId (UnknownErrorCode w) = w -- | Converting 'ErrorCode' to 'ErrorCodeId'. -- -- >>> toErrorCodeId 0 -- NoError -- >>> toErrorCodeId 0xc -- InadequateSecurity -- >>> toErrorCodeId 0xe -- UnknownErrorCode 14 toErrorCodeId :: ErrorCode -> ErrorCodeId toErrorCodeId 0x0 = NoError toErrorCodeId 0x1 = ProtocolError toErrorCodeId 0x2 = InternalError toErrorCodeId 0x3 = FlowControlError toErrorCodeId 0x4 = SettingsTimeout toErrorCodeId 0x5 = StreamClosed toErrorCodeId 0x6 = FrameSizeError toErrorCodeId 0x7 = RefusedStream toErrorCodeId 0x8 = Cancel toErrorCodeId 0x9 = CompressionError toErrorCodeId 0xa = ConnectError toErrorCodeId 0xb = EnhanceYourCalm toErrorCodeId 0xc = InadequateSecurity toErrorCodeId 0xd = HTTP11Required toErrorCodeId w = UnknownErrorCode w ---------------------------------------------------------------- -- | The connection error or the stream error. data HTTP2Error = ConnectionError ErrorCodeId ByteString | StreamError ErrorCodeId StreamId deriving (Eq, Show, Typeable, Read) instance E.Exception HTTP2Error -- | Obtaining 'ErrorCodeId' from 'HTTP2Error'. errorCodeId :: HTTP2Error -> ErrorCodeId errorCodeId (ConnectionError err _) = err errorCodeId (StreamError err _) = err ---------------------------------------------------------------- -- | The type for SETTINGS key. data SettingsKeyId = SettingsHeaderTableSize | SettingsEnablePush | SettingsMaxConcurrentStreams | SettingsInitialWindowSize | SettingsMaxFrameSize -- this means payload size | SettingsMaxHeaderBlockSize deriving (Show, Read, Eq, Ord, Enum, Bounded) -- | The type for raw SETTINGS value. type SettingsValue = Int -- Word32 -- | Converting 'SettingsKeyId' to raw value. -- -- >>> fromSettingsKeyId SettingsHeaderTableSize -- 1 -- >>> fromSettingsKeyId SettingsMaxHeaderBlockSize -- 6 fromSettingsKeyId :: SettingsKeyId -> Word16 fromSettingsKeyId x = fromIntegral (fromEnum x) + 1 minSettingsKeyId :: Word16 minSettingsKeyId = fromIntegral $ fromEnum (minBound :: SettingsKeyId) maxSettingsKeyId :: Word16 maxSettingsKeyId = fromIntegral $ fromEnum (maxBound :: SettingsKeyId) -- | Converting raw value to 'SettingsKeyId'. -- -- >>> toSettingsKeyId 0 -- Nothing -- >>> toSettingsKeyId 1 -- Just SettingsHeaderTableSize -- >>> toSettingsKeyId 6 -- Just SettingsMaxHeaderBlockSize -- >>> toSettingsKeyId 7 -- Nothing toSettingsKeyId :: Word16 -> Maybe SettingsKeyId toSettingsKeyId x | minSettingsKeyId <= n && n <= maxSettingsKeyId = Just . toEnum . fromIntegral $ n | otherwise = Nothing where n = x - 1 ---------------------------------------------------------------- -- | Association list of SETTINGS. type SettingsList = [(SettingsKeyId,SettingsValue)] -- | Checking 'SettingsList' and reporting an error if any. -- -- >>> checkSettingsList [(SettingsEnablePush,2)] -- Just (ConnectionError ProtocolError "enable push must be 0 or 1") checkSettingsList :: SettingsList -> Maybe HTTP2Error checkSettingsList settings = case mapMaybe checkSettingsValue settings of [] -> Nothing (x:_) -> Just x checkSettingsValue :: (SettingsKeyId,SettingsValue) -> Maybe HTTP2Error checkSettingsValue (SettingsEnablePush,v) | v /= 0 && v /= 1 = Just $ ConnectionError ProtocolError "enable push must be 0 or 1" checkSettingsValue (SettingsInitialWindowSize,v) | v > 2147483647 = Just $ ConnectionError FlowControlError "Window size must be less than or equal to 65535" checkSettingsValue (SettingsMaxFrameSize,v) | v < 16384 || v > 16777215 = Just $ ConnectionError ProtocolError "Max frame size must be in between 16384 and 16777215" checkSettingsValue _ = Nothing ---------------------------------------------------------------- -- | Cooked version of settings. This is suitable to be stored in a HTTP/2 context. data Settings = Settings { headerTableSize :: Int , enablePush :: Bool , maxConcurrentStreams :: Maybe Int , initialWindowSize :: WindowSize , maxFrameSize :: Int , maxHeaderBlockSize :: Maybe Int } deriving (Show) -- | The default settings. -- -- >>> defaultSettings -- Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Nothing, initialWindowSize = 65535, maxFrameSize = 16384, maxHeaderBlockSize = Nothing} defaultSettings :: Settings defaultSettings = Settings { headerTableSize = 4096 , enablePush = True , maxConcurrentStreams = Nothing , initialWindowSize = defaultInitialWindowSize , maxFrameSize = 16384 , maxHeaderBlockSize = Nothing } -- | Updating settings. -- -- >>> updateSettings defaultSettings [(SettingsEnablePush,0),(SettingsMaxHeaderBlockSize,200)] -- Settings {headerTableSize = 4096, enablePush = False, maxConcurrentStreams = Nothing, initialWindowSize = 65535, maxFrameSize = 16384, maxHeaderBlockSize = Just 200} updateSettings :: Settings -> SettingsList -> Settings updateSettings settings kvs = foldr update settings kvs where update (SettingsHeaderTableSize,x) def = def { headerTableSize = x } -- fixme: x should be 0 or 1 update (SettingsEnablePush,x) def = def { enablePush = x > 0 } update (SettingsMaxConcurrentStreams,x) def = def { maxConcurrentStreams = Just x } update (SettingsInitialWindowSize,x) def = def { initialWindowSize = x } update (SettingsMaxFrameSize,x) def = def { maxFrameSize = x } update (SettingsMaxHeaderBlockSize,x) def = def { maxHeaderBlockSize = Just x } -- | The type for window size. type WindowSize = Int -- | The default initial window size. -- -- >>> defaultInitialWindowSize -- 65535 defaultInitialWindowSize :: WindowSize defaultInitialWindowSize = 65535 -- | The maximum window size. -- -- >>> maxWindowSize -- 2147483647 maxWindowSize :: WindowSize maxWindowSize = 2147483647 -- | Checking if a window size exceeds the maximum window size. -- -- >>> isWindowOverflow 10 -- False -- >>> isWindowOverflow maxWindowSize -- False -- >>> isWindowOverflow (maxWindowSize + 1) -- True isWindowOverflow :: WindowSize -> Bool isWindowOverflow w = testBit w 31 -- | Default concurrency. -- -- >>> recommendedConcurrency -- 100 recommendedConcurrency :: Int recommendedConcurrency = 100 ---------------------------------------------------------------- -- | The type for weight in priority. Its values are from 1 to 256. type Weight = Int -- | Type for stream priority data Priority = Priority { exclusive :: Bool , streamDependency :: StreamId , weight :: Weight } deriving (Show, Read, Eq) -- | Default priority which depends on stream 0. -- -- >>> defaultPriority -- Priority {exclusive = False, streamDependency = 0, weight = 16} defaultPriority :: Priority defaultPriority = Priority False 0 16 -- | Highest priority which depends on stream 0. -- -- >>> highestPriority -- Priority {exclusive = False, streamDependency = 0, weight = 256} highestPriority :: Priority highestPriority = Priority False 0 256 ---------------------------------------------------------------- -- | The type for raw frame type. type FrameType = Word8 minFrameType :: FrameType minFrameType = 0 maxFrameType :: FrameType maxFrameType = 9 -- | The type for frame type. data FrameTypeId = FrameData | FrameHeaders | FramePriority | FrameRSTStream | FrameSettings | FramePushPromise | FramePing | FrameGoAway | FrameWindowUpdate | FrameContinuation | FrameUnknown FrameType deriving (Show, Eq, Ord) -- | Converting 'FrameTypeId' to 'FrameType'. -- -- >>> fromFrameTypeId FrameData -- 0 -- >>> fromFrameTypeId FrameContinuation -- 9 -- >>> fromFrameTypeId (FrameUnknown 10) -- 10 fromFrameTypeId :: FrameTypeId -> FrameType fromFrameTypeId FrameData = 0 fromFrameTypeId FrameHeaders = 1 fromFrameTypeId FramePriority = 2 fromFrameTypeId FrameRSTStream = 3 fromFrameTypeId FrameSettings = 4 fromFrameTypeId FramePushPromise = 5 fromFrameTypeId FramePing = 6 fromFrameTypeId FrameGoAway = 7 fromFrameTypeId FrameWindowUpdate = 8 fromFrameTypeId FrameContinuation = 9 fromFrameTypeId (FrameUnknown x) = x -- | Converting 'FrameType' to 'FrameTypeId'. -- -- >>> toFrameTypeId 0 -- FrameData -- >>> toFrameTypeId 9 -- FrameContinuation -- >>> toFrameTypeId 10 -- FrameUnknown 10 toFrameTypeId :: FrameType -> FrameTypeId toFrameTypeId 0 = FrameData toFrameTypeId 1 = FrameHeaders toFrameTypeId 2 = FramePriority toFrameTypeId 3 = FrameRSTStream toFrameTypeId 4 = FrameSettings toFrameTypeId 5 = FramePushPromise toFrameTypeId 6 = FramePing toFrameTypeId 7 = FrameGoAway toFrameTypeId 8 = FrameWindowUpdate toFrameTypeId 9 = FrameContinuation toFrameTypeId x = FrameUnknown x ---------------------------------------------------------------- -- | The maximum length of HTTP/2 payload. -- -- >>> maxPayloadLength -- 16384 maxPayloadLength :: Int maxPayloadLength = 2^(14::Int) ---------------------------------------------------------------- -- Flags -- | The type for flags. type FrameFlags = Word8 -- | The initial value of flags. No flags are set. -- -- >>> defaultFlags -- 0 defaultFlags :: FrameFlags defaultFlags = 0 -- | Checking if the END_STREAM flag is set. -- >>> testEndStream 0x1 -- True testEndStream :: FrameFlags -> Bool testEndStream x = x `testBit` 0 -- | Checking if the ACK flag is set. -- >>> testAck 0x1 -- True testAck :: FrameFlags -> Bool testAck x = x `testBit` 0 -- fixme: is the spec intentional? -- | Checking if the END_HEADERS flag is set. -- -- >>> testEndHeader 0x4 -- True testEndHeader :: FrameFlags -> Bool testEndHeader x = x `testBit` 2 -- | Checking if the PADDED flag is set. -- -- >>> testPadded 0x8 -- True testPadded :: FrameFlags -> Bool testPadded x = x `testBit` 3 -- | Checking if the PRIORITY flag is set. -- -- >>> testPriority 0x20 -- True testPriority :: FrameFlags -> Bool testPriority x = x `testBit` 5 -- | Setting the END_STREAM flag. -- -- >>> setEndStream 0 -- 1 setEndStream :: FrameFlags -> FrameFlags setEndStream x = x `setBit` 0 -- | Setting the ACK flag. -- -- >>> setAck 0 -- 1 setAck :: FrameFlags -> FrameFlags setAck x = x `setBit` 0 -- fixme: is the spec intentional? -- | Setting the END_HEADERS flag. -- -- >>> setEndHeader 0 -- 4 setEndHeader :: FrameFlags -> FrameFlags setEndHeader x = x `setBit` 2 -- | Setting the PADDED flag. -- -- >>> setPadded 0 -- 8 setPadded :: FrameFlags -> FrameFlags setPadded x = x `setBit` 3 -- | Setting the PRIORITY flag. -- -- >>> setPriority 0 -- 32 setPriority :: FrameFlags -> FrameFlags setPriority x = x `setBit` 5 ---------------------------------------------------------------- -- | The type for stream identifier type StreamId = Int -- | Checking if the stream identifier for control. -- -- >>> isControl 0 -- True -- >>> isControl 1 -- False isControl :: StreamId -> Bool isControl 0 = True isControl _ = False -- | Checking if the stream identifier for request. -- -- >>> isRequest 0 -- False -- >>> isRequest 1 -- True isRequest :: StreamId -> Bool isRequest = odd -- | Checking if the stream identifier for response. -- -- >>> isResponse 0 -- False -- >>> isResponse 2 -- True isResponse :: StreamId -> Bool isResponse 0 = False isResponse n = even n -- | Checking if the exclusive flag is set. testExclusive :: StreamId -> Bool testExclusive n = n `testBit` 31 -- | Setting the exclusive flag. setExclusive :: StreamId -> StreamId setExclusive n = n `setBit` 31 -- | Clearing the exclusive flag. clearExclusive :: StreamId -> StreamId clearExclusive n = n `clearBit` 31 ---------------------------------------------------------------- -- | The type for fragments of a header encoded with HPACK. type HeaderBlockFragment = ByteString -- | The type for padding in payloads. type Padding = ByteString ---------------------------------------------------------------- -- | The data type for HTTP/2 frames. data Frame = Frame { frameHeader :: FrameHeader , framePayload :: FramePayload } deriving (Show, Read, Eq) -- | The data type for HTTP/2 frame headers. data FrameHeader = FrameHeader { payloadLength :: Int , flags :: FrameFlags , streamId :: StreamId } deriving (Show, Read, Eq) -- | The data type for HTTP/2 frame payloads. data FramePayload = DataFrame ByteString | HeadersFrame (Maybe Priority) HeaderBlockFragment | PriorityFrame Priority | RSTStreamFrame ErrorCodeId | SettingsFrame SettingsList | PushPromiseFrame StreamId HeaderBlockFragment | PingFrame ByteString | GoAwayFrame StreamId ErrorCodeId ByteString | WindowUpdateFrame WindowSize | ContinuationFrame HeaderBlockFragment | UnknownFrame FrameType ByteString deriving (Show, Read, Eq) ---------------------------------------------------------------- -- | Getting 'FrameType' from 'FramePayload'. -- -- >>> framePayloadToFrameTypeId (DataFrame "body") -- FrameData framePayloadToFrameTypeId :: FramePayload -> FrameTypeId framePayloadToFrameTypeId (DataFrame _) = FrameData framePayloadToFrameTypeId (HeadersFrame _ _) = FrameHeaders framePayloadToFrameTypeId (PriorityFrame _) = FramePriority framePayloadToFrameTypeId (RSTStreamFrame _) = FrameRSTStream framePayloadToFrameTypeId (SettingsFrame _) = FrameSettings framePayloadToFrameTypeId (PushPromiseFrame _ _) = FramePushPromise framePayloadToFrameTypeId (PingFrame _) = FramePing framePayloadToFrameTypeId (GoAwayFrame _ _ _) = FrameGoAway framePayloadToFrameTypeId (WindowUpdateFrame _) = FrameWindowUpdate framePayloadToFrameTypeId (ContinuationFrame _) = FrameContinuation framePayloadToFrameTypeId (UnknownFrame w8 _) = FrameUnknown w8 ---------------------------------------------------------------- -- | Checking if padding is defined in this frame type. -- -- >>> isPaddingDefined $ DataFrame "" -- True -- >>> isPaddingDefined $ PingFrame "" -- False isPaddingDefined :: FramePayload -> Bool isPaddingDefined (DataFrame _) = True isPaddingDefined (HeadersFrame _ _) = True isPaddingDefined (PriorityFrame _) = False isPaddingDefined (RSTStreamFrame _) = False isPaddingDefined (SettingsFrame _) = False isPaddingDefined (PushPromiseFrame _ _) = True isPaddingDefined (PingFrame _) = False isPaddingDefined (GoAwayFrame _ _ _) = False isPaddingDefined (WindowUpdateFrame _) = False isPaddingDefined (ContinuationFrame _) = False isPaddingDefined (UnknownFrame _ _) = False http2-1.3.1/Network/HTTP2/Priority/0000755000000000000000000000000012624764141015065 5ustar0000000000000000http2-1.3.1/Network/HTTP2/Priority/PSQ.hs0000644000000000000000000000723412624764141016072 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} module Network.HTTP2.Priority.PSQ ( Key , Precedence(..) , newPrecedence , PriorityQueue , empty , isEmpty , enqueue , dequeue , delete ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif import Data.Array (Array, listArray, (!)) import Data.IntPSQ (IntPSQ) import qualified Data.IntPSQ as P import Data.Word (Word64) ---------------------------------------------------------------- type Key = Int type Weight = Int type Deficit = Word64 -- | Internal representation of priority in priority queues. -- The precedence of a dequeued entry should be specified -- to 'enqueue' when the entry is enqueued again. data Precedence = Precedence { deficit :: {-# UNPACK #-} !Deficit , weight :: {-# UNPACK #-} !Weight -- stream dependency, used by the upper layer , dependency :: {-# UNPACK #-} !Key } deriving Show -- | For test only newPrecedence :: Weight -> Precedence newPrecedence w = Precedence 0 w 0 instance Eq Precedence where Precedence d1 _ _ == Precedence d2 _ _ = d1 == d2 instance Ord Precedence where Precedence d1 _ _ < Precedence d2 _ _ = d1 < d2 Precedence d1 _ _ <= Precedence d2 _ _ = d1 <= d2 type Heap a = IntPSQ Precedence a -- FIXME: The base (Word64) would be overflowed. -- In that case, the heap must be re-constructed. data PriorityQueue a = PriorityQueue { baseDeficit :: {-# UNPACK #-} !Deficit , queue :: Heap a } ---------------------------------------------------------------- deficitSteps :: Int deficitSteps = 65536 deficitList :: [Deficit] deficitList = map calc idxs where idxs = [1..256] :: [Double] calc w = round (fromIntegral deficitSteps / w) deficitTable :: Array Int Deficit deficitTable = listArray (1,256) deficitList weightToDeficit :: Weight -> Deficit weightToDeficit w = deficitTable ! w deficitLimit :: Deficit deficitLimit = 10000000000000000000 -- more than 2^63 and less than 2^63 + 2^62 ---------------------------------------------------------------- empty :: PriorityQueue a empty = PriorityQueue 0 P.empty isEmpty :: PriorityQueue a -> Bool isEmpty PriorityQueue{..} = P.null queue enqueue :: Key -> Precedence -> a -> PriorityQueue a -> PriorityQueue a enqueue k p v PriorityQueue{..} | deficit' < deficitLimit = fastPath | otherwise = slowPath where !d = weightToDeficit (weight p) !b = if deficit p == 0 then baseDeficit else deficit p !deficit' = b + d fastPath = PriorityQueue baseDeficit queue' where !p' = p { deficit = deficit' } !queue' = P.insert k p' v queue slowPath = PriorityQueue 0 queue'' where adjust (x,y,z) = (x,y',z) where !d' = deficit y - baseDeficit !y' = y { deficit = d' } !queue' = P.fromList $ map adjust $ P.toList queue !deficit'' = deficit' - baseDeficit !p'' = p { deficit = deficit'' } !queue'' = P.insert k p'' v queue' dequeue :: PriorityQueue a -> Maybe (Key, Precedence, a, PriorityQueue a) dequeue PriorityQueue{..} = case P.minView queue of Nothing -> Nothing Just (k, p, v, queue') | P.null queue' -> Just (k, p, v, empty) | otherwise -> let !base = deficit p in Just (k, p, v, PriorityQueue base queue') delete :: Key -> PriorityQueue a -> (Maybe a, PriorityQueue a) delete k PriorityQueue{..} = case P.findMin queue' of Nothing -> (mv, empty) Just (_,p,_) -> (mv, PriorityQueue (deficit p) queue') where (!mv,!queue') = P.alter f k queue f Nothing = (Nothing, Nothing) f (Just (_,v)) = (Just v, Nothing) http2-1.3.1/Network/HTTP2/Priority/Queue.hs0000644000000000000000000000230612624764141016506 0ustar0000000000000000{-# LANGUAGE CPP #-} module Network.HTTP2.Priority.Queue ( Precedence(..) , TPriorityQueue , new , isEmpty , enqueue , dequeue , delete ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif import Control.Concurrent.STM import Network.HTTP2.Priority.PSQ (PriorityQueue, Key, Precedence(..)) import qualified Network.HTTP2.Priority.PSQ as Q ---------------------------------------------------------------- newtype TPriorityQueue a = TPriorityQueue (TVar (PriorityQueue a)) new :: STM (TPriorityQueue a) new = TPriorityQueue <$> newTVar Q.empty isEmpty :: TPriorityQueue a -> STM Bool isEmpty (TPriorityQueue th) = Q.isEmpty <$> readTVar th enqueue :: TPriorityQueue a -> Key -> Precedence -> a -> STM () enqueue (TPriorityQueue th) k p v = modifyTVar' th $ Q.enqueue k p v dequeue :: TPriorityQueue a -> STM (Key, Precedence, a) dequeue (TPriorityQueue th) = do h <- readTVar th case Q.dequeue h of Nothing -> retry Just (k, p, v, h') -> do writeTVar th h' return (k, p, v) delete :: Key -> TPriorityQueue a -> STM (Maybe a) delete k (TPriorityQueue th) = do q <- readTVar th let (mv, q') = Q.delete k q writeTVar th q' return mv http2-1.3.1/test/0000755000000000000000000000000012624764141011731 5ustar0000000000000000http2-1.3.1/test/doctests.hs0000644000000000000000000000033612624764141014117 0ustar0000000000000000module Main where import Test.DocTest main :: IO () main = do doctest [ "-XOverloadedStrings" , "Network/HPACK.hs" ] doctest [ "-XOverloadedStrings" , "Network/HTTP2.hs" ] http2-1.3.1/test/Spec.hs0000644000000000000000000000005412624764141013156 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} http2-1.3.1/test/HPACK/0000755000000000000000000000000012624764141012557 5ustar0000000000000000http2-1.3.1/test/HPACK/DecodeSpec.hs0000644000000000000000000000310312624764141015106 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module HPACK.DecodeSpec where import Network.HPACK.HeaderBlock import Network.HPACK.Table import Network.HPACK.Types import Test.Hspec import HPACK.HeaderBlock spec :: Spec spec = do describe "fromHeaderBlock" $ do it "decodes HeaderList in request" $ do (c1,h1) <- newDynamicTableForDecoding 4096 >>= flip fromHeaderBlock d41 h1 `shouldBe` d41h (c2,h2) <- fromHeaderBlock c1 d42 h2 `shouldBe` d42h (_,h3) <- fromHeaderBlock c2 d43 h3 `shouldBe` d43h it "decodes HeaderList in response" $ do (c1,h1) <- newDynamicTableForDecoding 256 >>= flip fromHeaderBlock d61 h1 `shouldBe` d61h (c2,h2) <- fromHeaderBlock c1 d62 h2 `shouldBe` d62h (_,h3) <- fromHeaderBlock c2 d63 h3 `shouldBe` d63h it "decodes HeaderList even if an entry is larger than DynamicTable" $ do (c1,h1) <- newDynamicTableForDecoding 64 >>= flip fromHeaderBlock hb1 h1 `shouldBe` hl1 isDynamicTableEmpty c1 `shouldBe` True hb1 :: HeaderBlock hb1 = [Literal Add (Lit "custom-key") "custom-value" -- this is larger than the header table ,Literal Add (Lit "loooooooooooooooooooooooooooooooooooooooooog-key") "loooooooooooooooooooooooooooooooooooooooooog-value" ] hl1 :: HeaderList hl1 = [("custom-key","custom-value") ,("loooooooooooooooooooooooooooooooooooooooooog-key" ,"loooooooooooooooooooooooooooooooooooooooooog-value") ] http2-1.3.1/test/HPACK/HeaderBlock.hs0000644000000000000000000000617112624764141015263 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module HPACK.HeaderBlock where import Data.ByteString (ByteString) import Data.Hex import Data.Maybe (fromJust) import Network.HPACK.HeaderBlock import Network.HPACK.Types fromHexString :: ByteString -> ByteString fromHexString = fromJust . unhex ---------------------------------------------------------------- d41 :: HeaderBlock d41 = [ Indexed 2 , Indexed 6 , Indexed 4 , Literal Add (Idx 1) "www.example.com" ] d41h :: HeaderList d41h = [(":method","GET") ,(":scheme","http") ,(":path","/") ,(":authority","www.example.com") ] d41b :: ByteString d41b = fromHexString "828684418cf1e3c2e5f23a6ba0ab90f4ff" d42 :: HeaderBlock d42 = [ Indexed 2 , Indexed 6 , Indexed 4 , Indexed 62 , Literal Add (Idx 24) "no-cache" ] d42h :: HeaderList d42h = [(":method","GET") ,(":scheme","http") ,(":path","/") ,(":authority","www.example.com") ,("cache-control","no-cache")] d42b :: ByteString d42b = fromHexString "828684be5886a8eb10649cbf" d43 :: HeaderBlock d43 = [ Indexed 2 , Indexed 7 , Indexed 5 , Indexed 63 , Literal Add (Lit "custom-key") "custom-value" ] d43h :: HeaderList d43h = [(":method","GET") ,(":scheme","https") ,(":path","/index.html") ,(":authority","www.example.com") ,("custom-key","custom-value") ] d43b :: ByteString d43b = fromHexString "828785bf408825a849e95ba97d7f8925a849e95bb8e8b4bf" ---------------------------------------------------------------- d61 :: HeaderBlock d61 = [ Literal Add (Idx 8) "302" , Literal Add (Idx 24) "private" , Literal Add (Idx 33) "Mon, 21 Oct 2013 20:13:21 GMT" , Literal Add (Idx 46) "https://www.example.com" ] d61h :: HeaderList d61h = [(":status","302") ,("cache-control","private") ,("date","Mon, 21 Oct 2013 20:13:21 GMT") ,("location","https://www.example.com") ] d61b :: ByteString d61b = fromHexString "488264025885aec3771a4b6196d07abe941054d444a8200595040b8166e082a62d1bff6e919d29ad171863c78f0b97c8e9ae82ae43d3" d62 :: HeaderBlock d62 = [ Literal Add (Idx 8) "307" , Indexed 65 , Indexed 64 , Indexed 63 ] d62h :: HeaderList d62h = [(":status","307") ,("cache-control","private") ,("date","Mon, 21 Oct 2013 20:13:21 GMT") ,("location","https://www.example.com") ] d62b :: ByteString d62b = fromHexString "4883640effc1c0bf" d63 :: HeaderBlock d63 = [ Indexed 8 , Indexed 65 , Literal Add (Idx 33) "Mon, 21 Oct 2013 20:13:22 GMT" , Indexed 64 , Literal Add (Idx 26) "gzip" ,Literal Add (Idx 55) "foo=ASDJKHQKBZXOQWEOPIUAXQWEOIU; max-age=3600; version=1" ] d63h :: HeaderList d63h = [(":status","200") ,("cache-control","private") ,("date","Mon, 21 Oct 2013 20:13:22 GMT") ,("location","https://www.example.com") ,("content-encoding","gzip") ,("set-cookie","foo=ASDJKHQKBZXOQWEOPIUAXQWEOIU; max-age=3600; version=1")] d63b :: ByteString d63b = fromHexString "88c16196d07abe941054d444a8200595040b8166e084a62d1bffc05a839bd9ab77ad94e7821dd7f2e6c7b335dfdfcd5b3960d5af27087f3672c1ab270fb5291f9587316065c003ed4ee5b1063d5007" http2-1.3.1/test/HPACK/HeaderBlockSpec.hs0000644000000000000000000000274212624764141016076 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module HPACK.HeaderBlockSpec where import qualified Data.ByteString.Char8 as BS import Network.HPACK.HeaderBlock import Test.Hspec import Test.Hspec.QuickCheck import HPACK.HeaderBlock spec :: Spec spec = do describe "toByteString" $ do it "encodes HeaderBlock" $ do toByteString True d41 `shouldBe` d41b toByteString True d42 `shouldBe` d42b toByteString True d43 `shouldBe` d43b toByteString True d61 `shouldBe` d61b toByteString True d62 `shouldBe` d62b toByteString True d63 `shouldBe` d63b describe "fromByteString" $ do it "encodes HeaderBlock" $ do fromByteString d41b `shouldBe` Right d41 fromByteString d42b `shouldBe` Right d42 fromByteString d43b `shouldBe` Right d43 fromByteString d61b `shouldBe` Right d61 fromByteString d62b `shouldBe` Right d62 fromByteString d63b `shouldBe` Right d63 describe "toByteString & fromByteString" $ do prop "duality for request" $ \k v -> do let key = BS.pack ('k':k) val = BS.pack ('v':v) hb = [Literal Add (Lit key) val] fromByteString (toByteString True hb) `shouldBe` Right hb prop "duality for response" $ \v -> do let val = BS.pack ('v':v) hb = [Literal Add (Idx 3) val] fromByteString (toByteString True hb) `shouldBe` Right hb http2-1.3.1/test/HPACK/HuffmanSpec.hs0000644000000000000000000000355612624764141015323 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module HPACK.HuffmanSpec where import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Data.Char (toLower) import Data.Hex import Data.Maybe (fromJust) import Network.HPACK import Network.HPACK.Huffman import Test.Hspec import Test.Hspec.QuickCheck testData :: [(ByteString, ByteString)] testData = [ ("", "") , ("www.example.com", "f1e3c2e5f23a6ba0ab90f4ff") , ("no-cache", "a8eb10649cbf") , ("custom-key", "25a849e95ba97d7f") , ("custom-value", "25a849e95bb8e8b4bf") , ("private", "aec3771a4b") , ("Mon, 21 Oct 2013 20:13:21 GMT", "d07abe941054d444a8200595040b8166e082a62d1bff") , ("https://www.example.com", "9d29ad171863c78f0b97c8e9ae82ae43d3") , ("Mon, 21 Oct 2013 20:13:22 GMT", "d07abe941054d444a8200595040b8166e084a62d1bff") , ("gzip", "9bd9ab") , ("foo=ASDJKHQKBZXOQWEOPIUAXQWEOIU; max-age=3600; version=1", "94e7821dd7f2e6c7b335dfdfcd5b3960d5af27087f3672c1ab270fb5291f9587316065c003ed4ee5b1063d5007") ] shouldBeEncoded :: ByteString -> ByteString -> Expectation shouldBeEncoded inp out = enc inp `shouldBe` out where enc = BS.map toLower . hex . encode shouldBeDecoded :: ByteString -> Either DecodeError ByteString -> Expectation shouldBeDecoded inp out = dec inp `shouldBe` out where dec = decode . fromJust . unhex spec :: Spec spec = do describe "encode and decode" $ do prop "duality" $ \cs -> let bs = BS.pack cs in decode (encode bs) == Right bs describe "encode" $ do it "encodes" $ do mapM_ (\(x,y) -> x `shouldBeEncoded` y) testData describe "decode" $ do it "decodes" $ do "ff" `shouldBeDecoded` Left TooLongEos "ffffea" `shouldBeDecoded` Right "\9" "ffffeaff" `shouldBeDecoded` Left TooLongEos mapM_ (\(x,y) -> y `shouldBeDecoded` Right x) testData http2-1.3.1/test/HPACK/IntegerSpec.hs0000644000000000000000000000111512624764141015321 0ustar0000000000000000module HPACK.IntegerSpec where import Network.HPACK.HeaderBlock.Integer import Test.Hspec import Test.Hspec.QuickCheck import qualified Data.ByteString as BS dual :: Int -> Int -> Bool dual n i = decode n w (BS.pack ws) == x where w:ws = encode n x x = abs i spec :: Spec spec = do describe "encode and decode" $ do prop "duality" $ dual 1 prop "duality" $ dual 2 prop "duality" $ dual 3 prop "duality" $ dual 4 prop "duality" $ dual 5 prop "duality" $ dual 6 prop "duality" $ dual 7 prop "duality" $ dual 8 http2-1.3.1/test/HTTP2/0000755000000000000000000000000012624764141012572 5ustar0000000000000000http2-1.3.1/test/HTTP2/FrameSpec.hs0000644000000000000000000000325512624764141015000 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module HTTP2.FrameSpec where import Test.Hspec import Data.ByteString.Char8 () import Network.HTTP2.Decode import Network.HTTP2.Encode import Network.HTTP2.Types spec :: Spec spec = do describe "encodeFrameHeader & decodeFrameHeader" $ do it "encode/decodes frames properly" $ do let header = FrameHeader { payloadLength = 500 , flags = defaultFlags , streamId = 10 } wire = encodeFrameHeader FramePriority header fibHeader = decodeFrameHeader wire fibHeader `shouldBe` (FramePriority, header) describe "encodeFrame & decodeFrame" $ do it "encode/decodes frames properly" $ do let einfo = EncodeInfo { encodeFlags = defaultFlags , encodeStreamId = 2 , encodePadding = Nothing } payload = DataFrame "Hello, world!" wire = encodeFrame einfo payload Right frame = decodeFrame defaultSettings wire payload' = framePayload frame payload' `shouldBe` payload it "encode/decodes padded frames properly" $ do let einfo = EncodeInfo { encodeFlags = defaultFlags , encodeStreamId = 2 , encodePadding = Just "padding!" } payload = DataFrame "Hello, world!" wire = encodeFrame einfo payload Right frame = decodeFrame defaultSettings wire payload' = framePayload frame payload' `shouldBe` payload http2-1.3.1/test/HTTP2/PrioritySpec.hs0000644000000000000000000000462512624764141015571 0ustar0000000000000000{-# LANGUAGE BangPatterns, CPP #-} module HTTP2.PrioritySpec where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Data.List (group, sort) import Test.Hspec import Network.HTTP2.Priority import qualified Network.HTTP2.Priority.PSQ as P import Network.HTTP2.Types spec :: Spec spec = do describe "priority tree" $ do it "enqueue and dequeue frames from Firefox properly" $ firefox describe "base priority queue" $ do it "queues entries based on weight" $ do let q = P.enqueue 5 (P.newPrecedence 1) 5 $ P.enqueue 3 (P.newPrecedence 101) 3 $ P.enqueue 1 (P.newPrecedence 201) 1 P.empty xs = enqdeq q 1000 map length (group (sort xs)) `shouldBe` [664,333,3] firefox :: IO () firefox = do pt <- newPriorityTree :: IO (PriorityTree Int) prepare pt 3 (pri 0 201) prepare pt 5 (pri 0 101) prepare pt 7 (pri 0 1) prepare pt 9 (pri 7 1) prepare pt 11 (pri 3 1) enQ pt 13 (pre 11 32) deQ pt `shouldReturn` 13 enQ pt 15 (pre 3 32) enQ pt 17 (pre 3 32) enQ pt 19 (pre 3 32) enQ pt 21 (pre 3 32) enQ pt 23 (pre 3 32) enQ pt 25 (pre 3 32) enQ pt 27 (pre 11 22) enQ pt 29 (pre 11 22) enQ pt 31 (pre 11 22) enQ pt 33 (pre 5 32) enQ pt 35 (pre 5 32) enQ pt 37 (pre 5 32) deQ pt `shouldReturn` 15 deQ pt `shouldReturn` 33 deQ pt `shouldReturn` 17 delete pt 17 (pre 3 32) `shouldReturn` Nothing delete pt 31 (pre 11 22) `shouldReturn` Just 31 deQ pt `shouldReturn` 19 deQ pt `shouldReturn` 35 deQ pt `shouldReturn` 21 deQ pt `shouldReturn` 23 deQ pt `shouldReturn` 37 deQ pt `shouldReturn` 25 deQ pt `shouldReturn` 27 deQ pt `shouldReturn` 29 enQ pt 39 (pre 3 32) deQ pt `shouldReturn` 39 enQ :: PriorityTree Int -> StreamId -> Precedence -> IO () enQ pt sid p = enqueue pt sid p sid deQ :: PriorityTree Int -> IO StreamId deQ pt = (\(x,_,_) -> x) <$> dequeue pt pri :: StreamId -> Weight -> Priority pri dep w = Priority False dep w pre :: StreamId -> Weight -> Precedence pre dep w = toPrecedence $ pri dep w enqdeq :: P.PriorityQueue Int -> Int -> [Int] enqdeq pq num = loop pq num [] where loop _ 0 ks = ks loop !q !n ks = case P.dequeue q of Nothing -> error "enqdeq" Just (k,p,v,q') -> loop (P.enqueue k p v q') (n - 1) (k:ks) http2-1.3.1/test-frame/0000755000000000000000000000000012624764141013021 5ustar0000000000000000http2-1.3.1/test-frame/Case.hs0000644000000000000000000000264112624764141014233 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, RecordWildCards, CPP #-} module Case where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif import Data.ByteString (ByteString) import Data.Hex import Data.Maybe (fromJust) import JSON import Network.HTTP2 data CaseSource = CaseSource { cs_description :: String , cs_encodeinfo :: EncodeInfo , cs_payload :: FramePayload } deriving (Show,Read) data CaseWire = CaseWire { wire_description :: String , wire_hex :: ByteString , wire_padding :: Maybe Pad , wire_error :: Maybe [ErrorCodeId] } deriving (Show,Read) sourceToWire :: CaseSource -> CaseWire sourceToWire CaseSource{..} = CaseWire { wire_description = cs_description , wire_hex = wire , wire_padding = Pad <$> encodePadding cs_encodeinfo , wire_error = Nothing } where frame = encodeFrame cs_encodeinfo cs_payload wire = hex frame wireToCase :: CaseWire -> Case wireToCase CaseWire { wire_error = Nothing, ..} = Case { description = wire_description , wire = wire_hex , frame = Just $ FramePad frm wire_padding , err = Nothing } where -- fromJust is unsafe frm = case decodeFrame defaultSettings $ fromJust $ unhex wire_hex of Left e -> error $ show e Right r -> r wireToCase CaseWire { wire_error = Just e, ..} = Case { description = wire_description , wire = wire_hex , frame = Nothing , err = Just $ fromErrorCodeId <$> e } http2-1.3.1/test-frame/frame-encode.hs0000644000000000000000000000106112624764141015700 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, RecordWildCards #-} module Main where import Data.Aeson import Data.Aeson.Encode.Pretty (encodePretty) import qualified Data.ByteString.Lazy.Char8 as BL import System.Environment (getArgs) import Case main :: IO () main = do args <- getArgs xs <- getContents if length args /= 0 then -- "-w" printWire xs else printJSON xs printWire :: String -> IO () printWire = print . sourceToWire . read printJSON :: String -> IO () printJSON = BL.putStrLn . encodePretty . toJSON . wireToCase . read http2-1.3.1/test-frame/JSON.hs0000644000000000000000000001642512624764141014136 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} {-# LANGUAGE OverloadedStrings, RecordWildCards, CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module JSON where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>), (<*>)) #endif import Control.Arrow (first) import Control.Monad (mzero) import Data.Aeson import Data.Aeson.Types import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8 import Data.HashMap.Strict (union) import Data.Maybe (fromJust, fromMaybe) import Data.Text (Text) import qualified Data.Text as T import Network.HTTP2 ---------------------------------------------------------------- byteStringToText :: ByteString -> Text byteStringToText = T.pack . B8.unpack textToByteString :: Text -> ByteString textToByteString = B8.pack . T.unpack (+++) :: Value -> Value -> Value Object x +++ Object y = Object $ x `union` y Null +++ x = x x +++ Null = x _ +++ _ = error "+++" ---------------------------------------------------------------- data FramePad = FramePad { fpFrame :: Frame , fpPad :: Maybe Pad } deriving (Show, Read) data Pad = Pad Padding deriving (Show, Read) unPad :: Pad -> Padding unPad (Pad x) = x ---------------------------------------------------------------- data Case = Case { description :: String , wire :: ByteString , frame :: Maybe FramePad , err :: Maybe [ErrorCode] } deriving (Show, Read) ---------------------------------------------------------------- {- instance ToJSON StreamIdentifier where toJSON (StreamIdentifier s) = toJSON s instance FromJSON StreamIdentifier where parseJSON x = StreamIdentifier <$> parseJSON x -} instance ToJSON ErrorCodeId where toJSON e = toJSON $ fromErrorCodeId e instance FromJSON ErrorCodeId where parseJSON e = toErrorCodeId <$> parseJSON e instance ToJSON SettingsList where toJSON settings = toJSON $ map (first fromSettingsKeyId) settings instance FromJSON SettingsList where parseJSON x = map (first (fromJust . toSettingsKeyId)) <$> parseJSON x instance ToJSON ByteString where toJSON bs = toJSON $ byteStringToText bs instance FromJSON ByteString where parseJSON x = textToByteString <$> parseJSON x ---------------------------------------------------------------- instance ToJSON FramePayload where toJSON (DataFrame body) = object [ "data" .= body ] toJSON (HeadersFrame mpri hdr) = object [ "exclusive" .= fromMaybe Null (toJSON . exclusive <$> mpri) , "stream_dependency" .= fromMaybe Null (toJSON . streamDependency <$> mpri) , "weight" .= fromMaybe Null (toJSON . weight <$> mpri) , "header_block_fragment" .= hdr ] toJSON (PriorityFrame pri) = object [ "exclusive" .= exclusive pri , "stream_dependency" .= streamDependency pri , "weight" .= weight pri ] toJSON (RSTStreamFrame e) = object [ "error_code" .= e ] toJSON (SettingsFrame settings) = object [ "settings" .= settings ] toJSON (PushPromiseFrame sid hdr) = object [ "promised_stream_id" .= sid , "header_block_fragment" .= hdr ] toJSON (PingFrame odata) = object [ "opaque_data" .= odata ] toJSON (GoAwayFrame sid e debug) = object [ "last_stream_id" .= sid , "error_code" .= e , "additional_debug_data" .= debug ] toJSON (WindowUpdateFrame size) = object [ "window_size_increment" .= size ] toJSON (ContinuationFrame hdr) = object [ "header_block_fragment" .= hdr ] toJSON (UnknownFrame _ opaque) = object [ "payload" .= opaque ] ---------------------------------------------------------------- instance ToJSON FramePad where toJSON FramePad{fpFrame = Frame{..},..} = object [ "length" .= payloadLength frameHeader , "type" .= fromFrameTypeId (framePayloadToFrameTypeId framePayload) , "flags" .= flags frameHeader , "stream_identifier" .= streamId frameHeader , "frame_payload" .= (toJSON framePayload +++ padObj) ] where padObj = case toJSON fpPad of Null | isPaddingDefined framePayload -> emptyPad | otherwise -> noPad x -> x instance FromJSON FramePad where parseJSON (Object o) = do len <- o .: "length" typ <- o .: "type" flg <- o .: "flags" sid <- o .: "stream_identifier" pld <- o .: "frame_payload" (payload,mpad) <- parsePayloadPad typ pld return FramePad { fpFrame = Frame { frameHeader = FrameHeader len flg sid , framePayload = payload } , fpPad = mpad } parseJSON _ = mzero parsePayloadPad :: FrameType -> Object -> Parser (FramePayload, Maybe Pad) parsePayloadPad ftyp o = do mpad <- (Pad <$>) <$> o .:? "padding" payload <- parsePayload ftid o return (payload, mpad) where ftid = toFrameTypeId ftyp priority :: Object -> Parser Priority priority o = Priority <$> o .: "exclusive" <*> o .: "stream_dependency" <*> o .: "weight" mpriority :: Object -> Parser (Maybe Priority) mpriority o = do me <- o .:? "exclusive" ms <- o .:? "stream_dependency" mw <- o .:? "weight" return $ case me of Nothing -> Nothing Just ex -> Just $ Priority ex (fromJust ms) (fromJust mw) parsePayload :: FrameTypeId -> Object -> Parser FramePayload parsePayload FrameData o = DataFrame <$> o .: "data" parsePayload FrameHeaders o = do mpri <- mpriority o hdr <- o .: "header_block_fragment" return $ HeadersFrame mpri hdr parsePayload FramePriority o = PriorityFrame <$> priority o parsePayload FrameRSTStream o = RSTStreamFrame <$> o .: "error_code" parsePayload FrameSettings o = SettingsFrame <$> o .: "settings" parsePayload FramePushPromise o = PushPromiseFrame <$> o .: "promised_stream_id" <*> o .: "header_block_fragment" parsePayload FramePing o = PingFrame <$> o .: "opaque_data" parsePayload FrameGoAway o = GoAwayFrame <$> o .: "last_stream_id" <*> o .: "error_code" <*> o .: "additional_debug_data" parsePayload FrameWindowUpdate o = WindowUpdateFrame <$> o .: "window_size_increment" parsePayload FrameContinuation o = ContinuationFrame <$> o .: "header_block_fragment" parsePayload (FrameUnknown typ) o = UnknownFrame typ <$> o .: "dummy" instance ToJSON Pad where toJSON (Pad padding) = object [ "padding_length" .= BS.length padding , "padding" .= padding ] emptyPad :: Value emptyPad = object [ "padding_length" .= Null , "padding" .= Null ] noPad :: Value noPad = object [] ---------------------------------------------------------------- instance ToJSON Case where toJSON Case{..} = object [ "description" .= description , "wire" .= wire , "frame" .= frame , "error" .= err ] instance FromJSON Case where parseJSON (Object o) = Case <$> o .: "description" <*> o .: "wire" <*> o .:? "frame" <*> o .:? "error" parseJSON _ = mzero http2-1.3.1/test-frame/Spec.hs0000644000000000000000000000005412624764141014246 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} http2-1.3.1/test-hpack/0000755000000000000000000000000012624764141013015 5ustar0000000000000000http2-1.3.1/test-hpack/hpack-debug.hs0000644000000000000000000000072012624764141015522 0ustar0000000000000000module Main where import Data.Aeson (eitherDecode) import qualified Data.ByteString.Lazy as BL import JSON import HPACKDecode main :: IO () main = do bs <- BL.getContents let etc = eitherDecode bs :: Either String Test res <- case etc of Left e -> return $ Just e Right tc -> do res <- run True tc case res of Pass -> return Nothing Fail e -> return $ Just e print res http2-1.3.1/test-hpack/hpack-encode.hs0000644000000000000000000000222012624764141015666 0ustar0000000000000000module Main where import Control.Monad (when) import Data.Aeson import Data.Aeson.Encode.Pretty (encodePretty) import qualified Data.ByteString.Lazy.Char8 as BL import System.Environment (getArgs) import System.Exit (exitFailure) import System.IO (hPutStrLn, stderr) import HPACKEncode import JSON main :: IO () main = do args <- getArgs when (length args /= 3) $ do hPutStrLn stderr "hpack-encode on/off naive|linear " exitFailure let [arg1,arg2,desc] = args huffman | arg1 == "on" = True | otherwise = False algo | arg2 == "naive" = Naive | arg2 == "static" = Static | otherwise = Linear stgy = EncodeStrategy algo huffman hpackEncode stgy desc hpackEncode :: EncodeStrategy -> String -> IO () hpackEncode stgy desc = do bs <- BL.getContents let Just tc = decode bs :: Maybe Test hexs <- run False stgy tc let cs = cases tc cs' = zipWith update cs hexs tc' = tc { description = desc , cases = cs' } BL.putStrLn $ encodePretty tc' where update c hex = c { wire = hex } http2-1.3.1/test-hpack/hpack-stat.hs0000644000000000000000000000504412624764141015413 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, CPP #-} module Main where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Data.Aeson import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Char8 as BL import Data.List import System.Directory import System.FilePath import Control.Monad import JSON hdir :: FilePath hdir = "test-hpack/hpack-test-case/nghttp2" wdir1 :: FilePath wdir1 = "test-hpack/hpack-test-case/haskell-http2-naive" wdir2 :: FilePath wdir2 = "test-hpack/hpack-test-case/haskell-http2-naive-huffman" wdir3 :: FilePath wdir3 = "test-hpack/hpack-test-case/haskell-http2-static" wdir4 :: FilePath wdir4 = "test-hpack/hpack-test-case/haskell-http2-static-huffman" wdir5 :: FilePath wdir5 = "test-hpack/hpack-test-case/haskell-http2-linear" wdir6 :: FilePath wdir6 = "test-hpack/hpack-test-case/haskell-http2-linear-huffman" main :: IO () main = do hs <- get getHeaderSize hdir hlen <- get getHeaderLen hdir ws1 <- get getWireSize wdir1 ws2 <- get getWireSize wdir2 ws3 <- get getWireSize wdir3 ws4 <- get getWireSize wdir4 ws5 <- get getWireSize wdir5 ws6 <- get getWireSize wdir6 let h :: Float = fromIntegral $ sum hs w1 :: Float = fromIntegral $ sum ws1 w2 :: Float = fromIntegral $ sum ws2 w3 :: Float = fromIntegral $ sum ws3 w4 :: Float = fromIntegral $ sum ws4 w5 :: Float = fromIntegral $ sum ws5 w6 :: Float = fromIntegral $ sum ws6 hl :: Float = fromIntegral $ sum hlen print (w1 / h ,w2 / h ,w3 / h ,w4 / h ,w5 / h ,w6 / h) print ((w4 - w6) / hl) get :: (FilePath -> IO Int) -> String -> IO [Int] get func dir = do files0 <- valid . sort <$> getDirectoryContents dir files1 <- filterM doesFileExist files0 mapM func files1 where valid = map (dir ) . filter (isSuffixOf ".json") getHeaderSize :: FilePath -> IO Int getHeaderSize file = do bs <- BL.readFile file let Just tc = decode bs :: Maybe Test let len = sum $ map toT $ cases tc return len where toT (Case _ _ hs _) = sum $ map (\(x,y) -> BS.length x + BS.length y) hs getHeaderLen :: FilePath -> IO Int getHeaderLen file = do bs <- BL.readFile file let Just tc = decode bs :: Maybe Test let len = length $ cases tc return len getWireSize :: FilePath -> IO Int getWireSize file = do bs <- BL.readFile file let Just tc = decode bs :: Maybe Test let len = sum $ map toT $ cases tc return len where toT (Case _ w _ _) = BS.length w `div` 2 http2-1.3.1/test-hpack/HPACKDecode.hs0000644000000000000000000000502312624764141015303 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, CPP #-} module HPACKDecode ( run , Result(..) , EncodeStrategy(..) , defaultEncodeStrategy , CompressionAlgo(..) ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif import Control.Exception import Control.Monad (when) import qualified Data.ByteString.Char8 as B8 import Data.Hex import Data.List (sort) import Network.HPACK import Network.HPACK.HeaderBlock import Network.HPACK.Table import JSON data Conf = Conf { debug :: Bool } data Result = Pass | Fail String deriving (Eq,Show) run :: Bool -> Test -> IO Result run _ (Test _ []) = return $ Pass run d (Test _ ccs) = do -- 'size c' must not be used. Initial value is 4,096! dhdrtbl <- newDynamicTableForDecoding 4096 let conf = Conf { debug = d } testLoop conf ccs dhdrtbl testLoop :: Conf -> [Case] -> DynamicTable -> IO Result testLoop _ [] _ = return $ Pass testLoop conf (c:cs) dhdrtbl = do res <- test conf c dhdrtbl case res of Right dhdrtbl' -> testLoop conf cs dhdrtbl' Left e -> return $ Fail e test :: Conf -> Case -> DynamicTable -> IO (Either String DynamicTable) test conf c dhdrtbl = do -- context is destructive!!! when (debug conf) $ do putStrLn "--------------------------------" putStrLn "---- Input header list" printHeaderList $ sort hs putStrLn "---- Input header table" printDynamicTable dhdrtbl putStrLn "---- Input Hex" B8.putStrLn wirehex putStrLn "---- Input header block" print bshd' dhdrtbl0 <- case size c of Nothing -> return dhdrtbl Just siz -> renewDynamicTable siz dhdrtbl x <- try $ decodeHeader dhdrtbl0 inp case x of Left e -> return $ Left $ show (e :: DecodeError) Right (dhdrtbl',hs') -> do let pass = sort hs == sort hs' if pass then return $ Right (dhdrtbl') else return $ Left $ "Headers are different in " ++ B8.unpack wirehex ++ ":\n" ++ show hd ++ "\n" ++ show hs ++ "\n" ++ show hs' where wirehex = wire c Just inp = unhex wirehex hs = headers c bshd = fromByteStringDebug inp hd = map snd <$> bshd bshd' = map (\(x,y)->(hex x,y)) <$> bshd -- | Printing 'HeaderList'. printHeaderList :: HeaderList -> IO () printHeaderList hs = mapM_ printHeader hs where printHeader (k,v) = do B8.putStr k putStr ": " B8.putStr v putStr "\n" http2-1.3.1/test-hpack/HPACKEncode.hs0000644000000000000000000000261212624764141015316 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module HPACKEncode ( run , EncodeStrategy(..) , defaultEncodeStrategy , CompressionAlgo(..) ) where import Control.Monad (when) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as C8 import Data.Char import Data.Hex import Network.HPACK import Network.HPACK.Table import JSON data Conf = Conf { debug :: Bool , enc :: HPACKEncoding } run :: Bool -> EncodeStrategy -> Test -> IO [ByteString] run _ _ (Test _ []) = return [] run d stgy (Test _ ccs@(c:_)) = do let siz = maybe 4096 id $ size c ehdrtbl <- newDynamicTableForEncoding siz let conf = Conf { debug = d, enc = encodeHeader stgy } testLoop conf ccs ehdrtbl [] testLoop :: Conf -> [Case] -> DynamicTable -> [ByteString] -> IO [ByteString] testLoop _ [] _ hexs = return $ reverse hexs testLoop conf (c:cs) ehdrtbl hxs = do (ehdrtbl',hx) <- test conf c ehdrtbl testLoop conf cs ehdrtbl' (C8.map toLower hx : hxs) test :: Conf -> Case -> DynamicTable -> IO (DynamicTable, ByteString) test conf c ehdrtbl = do (ehdrtbl',out) <- enc conf ehdrtbl hs let hex' = hex out when (debug conf) $ do putStrLn "---- Output context" printDynamicTable ehdrtbl' putStrLn "--------------------------------" return (ehdrtbl', hex') where hs = headers c http2-1.3.1/test-hpack/HPACKSpec.hs0000644000000000000000000000321512624764141015013 0ustar0000000000000000{-# LANGUAGE CPP #-} module HPACKSpec where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif import Control.Monad (forM_, filterM) import Data.Aeson (eitherDecode) import qualified Data.ByteString.Lazy as BL import Data.List (isPrefixOf, isSuffixOf) import System.Directory (getDirectoryContents, doesDirectoryExist, doesFileExist) import System.FilePath (()) import Test.Hspec import JSON import HPACKDecode testDir :: FilePath testDir = "test-hpack/hpack-test-case" getTestFiles :: FilePath -> IO [FilePath] getTestFiles dir = do subdirs0 <- valid <$> getDirectoryContents dir subdirs1 <- filterM doesDirectoryExist subdirs0 concat <$> mapM getTestFiles' subdirs1 where valid = map (testDir ) . filter ("raw-data" /=) . filter (not . isPrefixOf ".") getTestFiles' :: FilePath -> IO [FilePath] getTestFiles' subdir = do files0 <- valid <$> getDirectoryContents subdir filterM doesFileExist files0 where valid = map (subdir ) . filter (isSuffixOf ".json") test :: FilePath -> IO (Maybe String) test file = do bs <- BL.readFile file let etc = eitherDecode bs :: Either String Test case etc of Left e -> return $ Just $ file ++ ": " ++ e Right tc -> do res <- run False tc case res of Pass -> return Nothing Fail e -> return $ Just $ file ++ ": " ++ e spec :: Spec spec = do describe "decodeRequestHeader" $ do it "decodes headers in request" $ do files <- getTestFiles testDir forM_ files $ \file -> do putStrLn file test file `shouldReturn` Nothing http2-1.3.1/test-hpack/JSON.hs0000644000000000000000000000602712624764141014127 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module JSON ( Test(..) , Case(..) , HeaderList ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Control.Monad (mzero) import Data.Aeson import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B8 import qualified Data.HashMap.Strict as H import Data.Text (Text) import qualified Data.Text as T import Data.Vector ((!)) import qualified Data.Vector as V import Network.HPACK {- import Data.Aeson.Encode.Pretty (encodePretty) import qualified Data.ByteString.Lazy as BL main :: IO () main = do bs <- BL.getContents let Right x = eitherDecode bs :: Either String Test BL.putStr $ encodePretty x -} data Test = Test { description :: String , cases :: [Case] } deriving Show data Case = Case { size :: Maybe Int , wire :: ByteString , headers :: HeaderList , seqno :: Maybe Int } deriving Show instance FromJSON Test where parseJSON (Object o) = Test <$> o .: "description" <*> o .: "cases" parseJSON _ = mzero instance ToJSON Test where toJSON (Test desc cs) = object ["description" .= desc ,"cases" .= cs ] instance FromJSON Case where parseJSON (Object o) = Case <$> o .:? "header_table_size" <*> (textToByteString <$> (o .: "wire")) <*> o .: "headers" <*> o .:? "seqno" parseJSON _ = mzero instance ToJSON Case where toJSON (Case (Just siz) w hs no) = object ["header_table_size" .= siz ,"wire" .= byteStringToText w ,"headers" .= hs ,"seqno" .= no ] toJSON (Case Nothing w hs no) = object ["wire" .= byteStringToText w ,"headers" .= hs ,"seqno" .= no ] instance FromJSON HeaderList where parseJSON (Array a) = mapM parseJSON $ V.toList a parseJSON _ = mzero instance ToJSON HeaderList where toJSON hs = toJSON $ map toJSON hs instance FromJSON Header where parseJSON (Array a) = pure (toKey (a ! 0), toValue (a ! 1)) -- old where toKey = toValue parseJSON (Object o) = pure (textToByteString k, toValue v) -- new where (k,v) = head $ H.toList o parseJSON _ = mzero instance ToJSON Header where toJSON (k,v) = object [ byteStringToText k .= byteStringToText v ] textToByteString :: Text -> ByteString textToByteString = B8.pack . T.unpack byteStringToText :: ByteString -> Text byteStringToText = T.pack . B8.unpack toValue :: Value -> ByteString toValue (String s) = textToByteString s toValue _ = error "toValue" http2-1.3.1/test-hpack/Spec.hs0000644000000000000000000000005412624764141014242 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-}