)
where
-import Data.ByteString.Base (ByteString, toForeignPtr, w2c, inlinePerformIO)
-import qualified Data.ByteString.Char8 as C8
+import qualified Data.ByteString as Strict (ByteString)
+import Data.ByteString.Internal (toForeignPtr, w2c, inlinePerformIO)
+import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
import Data.Char
import Data.List
import Data.Map (Map)
import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.Storable
+import Network.HTTP.Lucu.HandleLike
import Network.HTTP.Lucu.Parser
import Network.HTTP.Lucu.Parser.Http
import Network.HTTP.Lucu.Utils
-import System.IO
-type Headers = Map NCBS ByteString
-newtype NCBS = NCBS ByteString
+type Headers = Map NCBS Strict.ByteString
+newtype NCBS = NCBS Strict.ByteString
-toNCBS :: ByteString -> NCBS
+toNCBS :: Strict.ByteString -> NCBS
toNCBS = NCBS
{-# INLINE toNCBS #-}
-fromNCBS :: NCBS -> ByteString
+fromNCBS :: NCBS -> Strict.ByteString
fromNCBS (NCBS x) = x
{-# INLINE fromNCBS #-}
instance Show NCBS where
show (NCBS x) = show x
-noCaseCmp :: ByteString -> ByteString -> Ordering
+noCaseCmp :: Strict.ByteString -> Strict.ByteString -> Ordering
noCaseCmp a b = a `seq` b `seq`
toForeignPtr a `cmp` toForeignPtr b
where
x -> return x
-noCaseEq :: ByteString -> ByteString -> Bool
+noCaseEq :: Strict.ByteString -> Strict.ByteString -> Bool
noCaseEq a b = a `seq` b `seq`
toForeignPtr a `cmp` toForeignPtr b
where
getHeaders :: a -> Headers
setHeaders :: a -> Headers -> a
- getHeader :: ByteString -> a -> Maybe ByteString
+ getHeader :: Strict.ByteString -> a -> Maybe Strict.ByteString
getHeader key a
= key `seq` a `seq`
M.lookup (toNCBS key) (getHeaders a)
- deleteHeader :: ByteString -> a -> a
+ deleteHeader :: Strict.ByteString -> a -> a
deleteHeader key a
= key `seq` a `seq`
setHeaders a $ M.delete (toNCBS key) (getHeaders a)
- setHeader :: ByteString -> ByteString -> a -> a
+ setHeader :: Strict.ByteString -> Strict.ByteString -> a -> a
setHeader key val a
= key `seq` val `seq` a `seq`
setHeaders a $ M.insert (toNCBS key) val (getHeaders a)
emptyHeaders = M.empty
-toHeaders :: [(ByteString, ByteString)] -> Headers
+toHeaders :: [(Strict.ByteString, Strict.ByteString)] -> Headers
toHeaders xs = mkHeaders xs M.empty
-mkHeaders :: [(ByteString, ByteString)] -> Headers -> Headers
+mkHeaders :: [(Strict.ByteString, Strict.ByteString)] -> Headers -> Headers
mkHeaders [] m = m
mkHeaders ((key, val):xs) m = mkHeaders xs $
case M.lookup (toNCBS key) m of
Nothing -> M.insert (toNCBS key) val m
Just old -> M.insert (toNCBS key) (merge old val) m
where
- merge :: ByteString -> ByteString -> ByteString
+ merge :: Strict.ByteString -> Strict.ByteString -> Strict.ByteString
-- カンマ區切りである事を假定する。RFC ではカンマ區切りに出來ない
-- ヘッダは複數個あってはならない事になってゐる。
merge a b
| otherwise = C8.concat [a, C8.pack ", ", b]
-fromHeaders :: Headers -> [(ByteString, ByteString)]
+fromHeaders :: Headers -> [(Strict.ByteString, Strict.ByteString)]
fromHeaders hs = [(fromNCBS a, b) | (a, b) <- M.toList hs]
crlf
return $! toHeaders xs
where
- header :: Parser (ByteString, ByteString)
+ header :: Parser (Strict.ByteString, Strict.ByteString)
header = do name <- token
char ':'
-- FIXME: これは多少インチキだが、RFC 2616 のこの部分
else c)
-hPutHeaders :: Handle -> Headers -> IO ()
+hPutHeaders :: HandleLike h => h -> Headers -> IO ()
hPutHeaders h hds
= h `seq` hds `seq`
- mapM_ putH (M.toList hds) >> hPutStr h "\r\n"
+ mapM_ putH (M.toList hds) >> hPutBS h (C8.pack "\r\n")
where
- putH :: (NCBS, ByteString) -> IO ()
+ putH :: (NCBS, Strict.ByteString) -> IO ()
putH (name, value)
= name `seq` value `seq`
- do C8.hPutStr h (fromNCBS name)
- C8.hPutStr h (C8.pack ": ")
- C8.hPutStr h value
- C8.hPutStr h (C8.pack "\r\n")
+ do hPutBS h (fromNCBS name)
+ hPutBS h (C8.pack ": ")
+ hPutBS h value
+ hPutBS h (C8.pack "\r\n")