backup.

Network/HPACK2.hs

@@ -5,9 +5,7 @@ module Network.HPACK2 (
   -- * Encoding
     HPACKEncoding
   , encodeHeader
-  -- * Encoding with builders
-  , HPACKEncodingBuilder
-  , encodeHeaderBuilder
+--  , encodeHeaderBuffer
   -- * Decoding
   , HPACKDecoding
   , decodeHeader
@@ -40,7 +38,7 @@ import Control.Applicative ((<$>))
 #endif
 import Data.ByteString (ByteString)
 import Data.ByteString.Builder (Builder)
-import Network.HPACK2.HeaderBlock (toHeaderBlock, toByteString, decodeHeader, HPACKDecoding, toBuilder)
+import Network.HPACK2.HeaderBlock (toHeaderBlock, decodeHeader, HPACKDecoding)
 import Network.HPACK2.Table (DynamicTable, Size, newDynamicTableForEncoding, newDynamicTableForDecoding, setLimitForEncoding)
 import Network.HPACK2.Types
 
@@ -64,6 +62,9 @@ type HPACKEncodingBuilder = DynamicTable -> HeaderList -> IO Builder
 
 -- | Converting 'HeaderList' for HTTP header to the low level format.
 encodeHeader :: EncodeStrategy -> HPACKEncoding
+encodeHeader = undefined
+
+{-
 encodeHeader stgy ctx hs = toBS <$> toHeaderBlock algo ctx hs
   where
     algo = compressionAlgo stgy
@@ -75,3 +76,4 @@ encodeHeaderBuilder stgy ctx hs = toBB <$> toHeaderBlock algo ctx hs
   where
     algo = compressionAlgo stgy
     toBB = toBuilder (useHuffman stgy)
+-}

Network/HPACK2/Buffer.hs

@@ -6,10 +6,8 @@ module Network.HPACK2.Buffer (
   , WorkingBuffer
   , newWorkingBuffer
   , rewind1
-  , readW
   , readWord8
   , writeWord8
-  , finalPointer
   , toByteString
   , copyByteString
   , ReadBuffer
@@ -47,19 +45,9 @@ rewind1 WorkingBuffer{..} = do
     let !ptr' = ptr `plusPtr` (-1)
     writeIORef offset ptr'
 
-{-# INLINE readW #-}
-readW :: WorkingBuffer -> IO Word8
-readW WorkingBuffer{..} = readIORef offset >>= peek
-
 {-# INLINE readWord8 #-}
-readWord8 :: WorkingBuffer -> IO (Maybe Word8)
-readWord8 WorkingBuffer{..} = do
-    ptr <- readIORef offset
-    if ptr >= limit then
-        return Nothing
-      else do
-        w <- peek ptr
-        return $! Just w
+readWord8 :: WorkingBuffer -> IO Word8
+readWord8 WorkingBuffer{..} = readIORef offset >>= peek
 
 {-# INLINE writeWord8 #-}
 writeWord8 :: WorkingBuffer -> Word8 -> IO Bool
@@ -73,9 +61,6 @@ writeWord8 WorkingBuffer{..} w = do
         writeIORef offset ptr'
         return True
 
-finalPointer :: WorkingBuffer -> IO Buffer
-finalPointer WorkingBuffer{..} = readIORef offset
-
 {-# INLINE copyByteString #-}
 copyByteString :: WorkingBuffer -> ByteString -> IO Bool
 copyByteString WorkingBuffer{..} (PS fptr off len) = withForeignPtr fptr $ \ptr -> do

Network/HPACK2/HeaderBlock.hs

@@ -2,10 +2,8 @@ module Network.HPACK2.HeaderBlock (
   -- * Types for header block
     module Network.HPACK2.HeaderBlock.HeaderField
   -- * Header block from/to Low level
-  , toByteString
   , HPACKDecoding
   , decodeHeader
-  , toBuilder
   -- * Header block from/to header list
   , toHeaderBlock
   ) where

Network/HPACK2/HeaderBlock/Encode.hs

@@ -1,39 +1,97 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, BangPatterns, RecordWildCards, OverloadedStrings #-}
 
 module Network.HPACK2.HeaderBlock.Encode (
-    toByteString
-  , toBuilder
+    prepare
   ) where
 
+#if __GLASGOW_HASKELL__ < 709
+import Control.Applicative ((<$>))
+#endif
 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.HPACK2.HeaderBlock.HeaderField
+import Network.HPACK2.Buffer
 import qualified Network.HPACK2.HeaderBlock.Integer as I
-import qualified Network.HPACK2.HeaderBlock.String as S
+import qualified Network.HPACK2.Huffman as Huffman
+import Network.HPACK2.Table
+import Network.HPACK2.Types
+
+type Step = Bool -> DynamicTable -> WorkingBuffer -> Header -> IO ()
+
+prepare :: EncodeStrategy -> DynamicTable -> WorkingBuffer -> IO (DynamicTable -> WorkingBuffer -> Header -> IO ())
+prepare EncodeStrategy{..} dyntbl wbuf = do
+    msiz <- needChangeTableSize dyntbl
+    case msiz of
+        Keep -> return ()
+        Change lim -> do
+            renewDynamicTable lim dyntbl
+            change wbuf lim
+        Ignore lim -> do
+            resetLimitForEncoding dyntbl
+            change wbuf lim
+    return $ case compressionAlgo of
+        Naive  -> naiveStep  useHuffman
+        Static -> staticStep useHuffman
+        Linear -> linearStep useHuffman
 
 ----------------------------------------------------------------
 
--- | Converting 'HeaderBlock' to the low level format.
-toByteString :: Bool -> HeaderBlock -> ByteString
-toByteString huff hbs = BL.toStrict $ BB.toLazyByteString $ toBuilder huff hbs
+naiveStep :: Step
+naiveStep huff _dyntbl wbuf (k,v) = newName wbuf huff set0000 k v
+
+----------------------------------------------------------------
 
-toBuilder :: Bool -> [HeaderField] -> Builder
-toBuilder huff hbs = foldl' op mempty hbs
-  where
-    b `op` x = b <> toBB x
-    toBB = fromHeaderField huff
+staticStep :: Step
+staticStep huff dyntbl wbuf h@(k,v) = do
+    x <- lookupTable h dyntbl
+    case x of
+        None                      -> newName     wbuf huff   set0000 k v
+        KeyOnly  InStaticTable i  -> indexedName wbuf huff 4 set0000 i v
+        KeyOnly  InDynamicTable _ -> newName     wbuf huff   set0000 k v
+        KeyValue InStaticTable i  -> indexedName wbuf huff 4 set0000 i v
+        KeyValue InDynamicTable _ -> newName     wbuf huff   set0000 k v
 
+----------------------------------------------------------------
+-- A simple encoding strategy to reset the reference set first
+-- by 'Index 0' and uses indexing as much as possible.
+
+data Naming = Lit ByteString | Idx Int
+
+linearStep :: Step
+linearStep huff dyntbl wbuf h@(k,_) = do
+    cache <- lookupTable h dyntbl
+    case cache of
+        None                      -> check wbuf huff dyntbl h (Lit k) -- fixme: k
+        KeyOnly  InStaticTable  i -> check wbuf huff dyntbl h (Idx i)
+        KeyOnly  InDynamicTable i -> check wbuf huff dyntbl h (Idx i)
+        KeyValue InStaticTable  i -> index wbuf i
+        KeyValue InDynamicTable i -> index wbuf i
+
+check :: WorkingBuffer -> Bool -> DynamicTable -> Header -> Naming -> IO ()
+check wbuf huff dyntbl h@(k,v) x
+  | k `elem` headersNotToIndex = do
+      case x of
+          Lit k -> newName     wbuf huff set0000 k v
+          Idx i -> indexedName wbuf huff 4 set0000 i v
+  | otherwise = do
+      case x of
+          Lit k -> newName     wbuf huff set01 k v
+          Idx i -> indexedName wbuf huff 6 set01 i v
+      let e = toEntry h
+      insertEntry e dyntbl
+
+
+headersNotToIndex :: [HeaderName]
+headersNotToIndex = [
+    ":path"
+  , "content-length"
+  , "location"
+  , "etag"
+  , "set-cookie"
+  ]
+
+{-
 fromHeaderField :: Bool -> HeaderField -> Builder
 fromHeaderField _    (ChangeTableSize siz)        = change siz
 fromHeaderField _    (Indexed idx)                = index idx
@@ -43,67 +101,51 @@ fromHeaderField huff (Literal NotAdd (Idx idx) v) = indexedName huff 4 set0000 i
 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
+{-# INLINE change #-}
+change :: WorkingBuffer -> Int -> IO ()
+change wbuf i = I.encode wbuf set001 5 i >> return ()
 
-index :: Int -> Builder
-index i = word8s (w':ws)
-  where
-    (w:ws) = I.encode 7 i
-    w' = set1 w
+{-# INLINE index #-}
+index :: WorkingBuffer -> Int -> IO ()
+index wbuf i = I.encode wbuf id 7 i >> return () -- fixme id
 
 -- 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
+indexedName :: WorkingBuffer -> Bool -> Int -> Setter -> Int -> HeaderValue -> IO ()
+indexedName wbuf huff n set idx v = do
+    I.encode wbuf set n idx
+    encodeString huff v wbuf
 
 -- 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
+newName :: WorkingBuffer -> Bool -> Setter -> HeaderName -> HeaderValue -> IO ()
+newName wbuf huff set k v = do
+    writeWord8 wbuf $ set 0
+    encodeString huff k wbuf
+    encodeString huff v wbuf
 
 ----------------------------------------------------------------
 
 type Setter = Word8 -> Word8
 
 -- Assuming MSBs are 0.
-set1, set01, set001, set0001, set0000 :: Setter
+set1, set01, set001, set0001, set0000, setH :: Setter
 set1    x = x `setBit` 7
 set01   x = x `setBit` 6
 set001  x = x `setBit` 5
 set0001 x = x `setBit` 4
 set0000 = id
+setH = set1
+
+----------------------------------------------------------------
 
-setH :: [Word8] -> [Word8]
-setH []     = error "setH"
-setH (x:xs) = (x `setBit` 7) : xs
+encodeString :: Bool -> ByteString -> WorkingBuffer -> IO ()
+encodeString True bs wbuf = do
+    -- fixme!!!
+    Huffman.encode wbuf bs
+encodestring _    bs wbuf = do
+    let !len = BS.length bs
+    I.encode wbuf id 7 len
+    copyByteString wbuf bs >> return () -- fixme

Network/HPACK2/HeaderBlock/Integer.hs

@@ -14,13 +14,14 @@ import Network.HPACK2.Buffer
 -- $setup
 -- >>> import qualified Data.ByteString as BS
 
-----------------------------------------------------------------
-
 powerArray :: Array Int Int
 powerArray = listArray (1,8) [1,3,7,15,31,63,127,255]
 
+
 ----------------------------------------------------------------
 
+-- FIXME: buffer overrun
+
 {-
 if I < 2^N - 1, encode I on N bits
    else
@@ -32,27 +33,22 @@ if I < 2^N - 1, encode I on N bits
        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)
+encode :: WorkingBuffer -> (Word8 -> Word8) -> Int -> Int -> IO Bool -- fixme
+encode wbuf set n i
+  | i < p     = writeWord8 wbuf $ set $ fromIntegral i
+  | otherwise = do
+        writeWord8 wbuf $ set $ fromIntegral p
+        encode' wbuf (i - p)
   where
     p = powerArray ! n
 
-encode' :: Int -> [Word8]
-encode' i
-  | i < 128   = fromIntegral i : []
-  | otherwise = fromIntegral (r + 128) : encode' q
+encode' :: WorkingBuffer -> Int -> IO Bool
+encode' wbuf i
+  | i < 128   = writeWord8 wbuf $ fromIntegral i
+  | otherwise = do
+        writeWord8 wbuf $ fromIntegral (r + 128)
+        encode' wbuf q
   where
---    (q,r) = i `divMod` 128
     q = i `shiftR` 7
     r = i .&. 0x7f