module Network.HTTP.Lucu.Headers ( Headers , HasHeaders(..) , noCaseCmp , noCaseEq , emptyHeaders , toHeaders , fromHeaders , headersP , hPutHeaders ) where 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 qualified Data.Map as M import Data.Word 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 type Headers = Map NCBS Strict.ByteString newtype NCBS = NCBS Strict.ByteString toNCBS :: Strict.ByteString -> NCBS toNCBS = NCBS {-# INLINE toNCBS #-} fromNCBS :: NCBS -> Strict.ByteString fromNCBS (NCBS x) = x {-# INLINE fromNCBS #-} instance Eq NCBS where (NCBS a) == (NCBS b) = a == b instance Ord NCBS where (NCBS a) `compare` (NCBS b) = a `noCaseCmp` b instance Show NCBS where show (NCBS x) = show x noCaseCmp :: Strict.ByteString -> Strict.ByteString -> Ordering noCaseCmp a b = a `seq` b `seq` toForeignPtr a `cmp` toForeignPtr b where cmp :: (ForeignPtr Word8, Int, Int) -> (ForeignPtr Word8, Int, Int) -> Ordering cmp (x1, s1, l1) (x2, s2, l2) | x1 `seq` s1 `seq` l1 `seq` x2 `seq` s2 `seq` l2 `seq` False = undefined | l1 == 0 && l2 == 0 = EQ | x1 == x2 && s1 == s2 && l1 == l2 = EQ | otherwise = inlinePerformIO $ withForeignPtr x1 $ \ p1 -> withForeignPtr x2 $ \ p2 -> noCaseCmp' (p1 `plusPtr` s1) l1 (p2 `plusPtr` s2) l2 -- もし先頭の文字列が等しければ、短い方が小さい。 noCaseCmp' :: Ptr Word8 -> Int -> Ptr Word8 -> Int -> IO Ordering noCaseCmp' p1 l1 p2 l2 | p1 `seq` l1 `seq` p2 `seq` l2 `seq` False = undefined | l1 == 0 && l2 == 0 = return EQ | l1 == 0 = return LT | l2 == 0 = return GT | otherwise = do c1 <- peek p1 c2 <- peek p2 case toLower (w2c c1) `compare` toLower (w2c c2) of EQ -> noCaseCmp' (p1 `plusPtr` 1) (l1 - 1) (p2 `plusPtr` 1) (l2 - 1) x -> return x noCaseEq :: Strict.ByteString -> Strict.ByteString -> Bool noCaseEq a b = a `seq` b `seq` toForeignPtr a `cmp` toForeignPtr b where cmp :: (ForeignPtr Word8, Int, Int) -> (ForeignPtr Word8, Int, Int) -> Bool cmp (x1, s1, l1) (x2, s2, l2) | x1 `seq` s1 `seq` l1 `seq` x2 `seq` s2 `seq` l2 `seq` False = undefined | l1 /= l2 = False | l1 == 0 && l2 == 0 = True | x1 == x2 && s1 == s2 && l1 == l2 = True | otherwise = inlinePerformIO $ withForeignPtr x1 $ \ p1 -> withForeignPtr x2 $ \ p2 -> noCaseEq' (p1 `plusPtr` s1) (p2 `plusPtr` s2) l1 noCaseEq' :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool noCaseEq' p1 p2 l | p1 `seq` p2 `seq` l `seq` False = undefined | l == 0 = return True | otherwise = do c1 <- peek p1 c2 <- peek p2 if toLower (w2c c1) == toLower (w2c c2) then noCaseEq' (p1 `plusPtr` 1) (p2 `plusPtr` 1) (l - 1) else return False class HasHeaders a where getHeaders :: a -> Headers setHeaders :: a -> Headers -> a getHeader :: Strict.ByteString -> a -> Maybe Strict.ByteString getHeader key a = key `seq` a `seq` M.lookup (toNCBS key) (getHeaders a) deleteHeader :: Strict.ByteString -> a -> a deleteHeader key a = key `seq` a `seq` setHeaders a $ M.delete (toNCBS key) (getHeaders 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 :: Headers emptyHeaders = M.empty toHeaders :: [(Strict.ByteString, Strict.ByteString)] -> Headers toHeaders xs = mkHeaders xs M.empty 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 :: Strict.ByteString -> Strict.ByteString -> Strict.ByteString -- カンマ區切りである事を假定する。RFC ではカンマ區切りに出來ない -- ヘッダは複數個あってはならない事になってゐる。 merge a b | C8.null a && C8.null b = C8.empty | C8.null a = b | C8.null b = a | otherwise = C8.concat [a, C8.pack ", ", b] fromHeaders :: Headers -> [(Strict.ByteString, Strict.ByteString)] fromHeaders hs = [(fromNCBS a, b) | (a, b) <- M.toList hs] {- message-header = field-name ":" [ field-value ] field-name = token field-value = *( field-content | LWS ) field-content = field-value の先頭および末尾にある LWS は全て削除され、それ以外の LWS は單一の SP に變換される。 -} headersP :: Parser Headers headersP = do xs <- many header crlf return $! toHeaders xs where header :: Parser (Strict.ByteString, Strict.ByteString) header = do name <- token char ':' -- FIXME: これは多少インチキだが、RFC 2616 のこの部分 -- の記述はひどく曖昧であり、この動作が本當に間違って -- ゐるのかどうかも良く分からない。例へば -- quoted-string の内部にある空白は纏めていいのか惡い -- のか？直勸的には駄目さうに思へるが、そんな記述は見 -- 付からない。 contents <- many (lws <|> many1 text) crlf let value = foldr (++) "" contents norm = normalize value return (C8.pack name, C8.pack norm) normalize :: String -> String normalize = trimBody . trim isWhiteSpace trimBody = foldr (++) [] . map (\ s -> if head s == ' ' then " " else s) . group . map (\ c -> if isWhiteSpace c then ' ' else c) hPutHeaders :: HandleLike h => h -> Headers -> IO () hPutHeaders h hds = h `seq` hds `seq` mapM_ putH (M.toList hds) >> hPutBS h (C8.pack "\r\n") where putH :: (NCBS, Strict.ByteString) -> IO () putH (name, value) = name `seq` value `seq` do hPutBS h (fromNCBS name) hPutBS h (C8.pack ": ") hPutBS h value hPutBS h (C8.pack "\r\n")