1 module Network.HTTP.Lucu.Headers
17 import Data.ByteString.Base (ByteString, toForeignPtr, w2c, inlinePerformIO)
18 import qualified Data.ByteString.Char8 as C8
22 import qualified Data.Map as M
24 import Foreign.ForeignPtr
26 import Foreign.Storable
27 import Network.HTTP.Lucu.Parser
28 import Network.HTTP.Lucu.Parser.Http
29 import Network.HTTP.Lucu.Utils
32 type Headers = Map NCBS ByteString
33 newtype NCBS = NCBS ByteString
35 toNCBS :: ByteString -> NCBS
39 fromNCBS :: NCBS -> ByteString
41 {-# INLINE fromNCBS #-}
43 instance Eq NCBS where
44 (NCBS a) == (NCBS b) = a == b
46 instance Ord NCBS where
47 (NCBS a) `compare` (NCBS b) = a `noCaseCmp` b
49 instance Show NCBS where
50 show (NCBS x) = show x
52 noCaseCmp :: ByteString -> ByteString -> Ordering
53 noCaseCmp a b = a `seq` b `seq`
54 toForeignPtr a `cmp` toForeignPtr b
56 cmp :: (ForeignPtr Word8, Int, Int) -> (ForeignPtr Word8, Int, Int) -> Ordering
57 cmp (x1, s1, l1) (x2, s2, l2)
58 | x1 `seq` s1 `seq` l1 `seq` x2 `seq` s2 `seq` l2 `seq` False = undefined
59 | l1 == 0 && l2 == 0 = EQ
60 | x1 == x2 && s1 == s2 && l1 == l2 = EQ
63 withForeignPtr x1 $ \ p1 ->
64 withForeignPtr x2 $ \ p2 ->
65 noCaseCmp' (p1 `plusPtr` s1) l1 (p2 `plusPtr` s2) l2
68 -- もし先頭の文字列が等しければ、短い方が小さい。
69 noCaseCmp' :: Ptr Word8 -> Int -> Ptr Word8 -> Int -> IO Ordering
70 noCaseCmp' p1 l1 p2 l2
71 | p1 `seq` l1 `seq` p2 `seq` l2 `seq` False = undefined
72 | l1 == 0 && l2 == 0 = return EQ
78 case toLower (w2c c1) `compare` toLower (w2c c2) of
79 EQ -> noCaseCmp' (p1 `plusPtr` 1) (l1 - 1) (p2 `plusPtr` 1) (l2 - 1)
83 noCaseEq :: ByteString -> ByteString -> Bool
84 noCaseEq a b = a `seq` b `seq`
85 toForeignPtr a `cmp` toForeignPtr b
87 cmp :: (ForeignPtr Word8, Int, Int) -> (ForeignPtr Word8, Int, Int) -> Bool
88 cmp (x1, s1, l1) (x2, s2, l2)
89 | x1 `seq` s1 `seq` l1 `seq` x2 `seq` s2 `seq` l2 `seq` False = undefined
91 | l1 == 0 && l2 == 0 = True
92 | x1 == x2 && s1 == s2 && l1 == l2 = True
95 withForeignPtr x1 $ \ p1 ->
96 withForeignPtr x2 $ \ p2 ->
97 noCaseEq' (p1 `plusPtr` s1) (p2 `plusPtr` s2) l1
100 noCaseEq' :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool
102 | p1 `seq` p2 `seq` l `seq` False = undefined
103 | l == 0 = return True
107 if toLower (w2c c1) == toLower (w2c c2) then
108 noCaseEq' (p1 `plusPtr` 1) (p2 `plusPtr` 1) (l - 1)
113 class HasHeaders a where
114 getHeaders :: a -> Headers
115 setHeaders :: a -> Headers -> a
117 getHeader :: ByteString -> a -> Maybe ByteString
120 M.lookup (toNCBS key) (getHeaders a)
122 deleteHeader :: ByteString -> a -> a
125 setHeaders a $ M.delete (toNCBS key) (getHeaders a)
127 setHeader :: ByteString -> ByteString -> a -> a
129 = key `seq` val `seq` a `seq`
130 setHeaders a $ M.insert (toNCBS key) val (getHeaders a)
133 emptyHeaders :: Headers
134 emptyHeaders = M.empty
137 toHeaders :: [(ByteString, ByteString)] -> Headers
138 toHeaders xs = mkHeaders xs M.empty
141 mkHeaders :: [(ByteString, ByteString)] -> Headers -> Headers
143 mkHeaders ((key, val):xs) m = mkHeaders xs $
144 case M.lookup (toNCBS key) m of
145 Nothing -> M.insert (toNCBS key) val m
146 Just old -> M.insert (toNCBS key) (merge old val) m
148 merge :: ByteString -> ByteString -> ByteString
149 -- カンマ區切りである事を假定する。RFC ではカンマ區切りに出來ない
150 -- ヘッダは複數個あってはならない事になってゐる。
152 | C8.null a && C8.null b = C8.empty
155 | otherwise = C8.concat [a, C8.pack ", ", b]
158 fromHeaders :: Headers -> [(ByteString, ByteString)]
159 fromHeaders hs = [(fromNCBS a, b) | (a, b) <- M.toList hs]
163 message-header = field-name ":" [ field-value ]
165 field-value = *( field-content | LWS )
166 field-content = <field-value を構成し、*TEXT あるいは
167 token, separators, quoted-string を連結
170 field-value の先頭および末尾にある LWS は全て削除され、それ以外の
173 headersP :: Parser Headers
174 headersP = do xs <- many header
176 return $! toHeaders xs
178 header :: Parser (ByteString, ByteString)
179 header = do name <- token
181 -- FIXME: これは多少インチキだが、RFC 2616 のこの部分
182 -- の記述はひどく曖昧であり、この動作が本當に間違って
183 -- ゐるのかどうかも良く分からない。例へば
184 -- quoted-string の内部にある空白は纏めていいのか惡い
185 -- のか?直勸的には駄目さうに思へるが、そんな記述は見
187 contents <- many (lws <|> many1 text)
189 let value = foldr (++) "" contents
190 norm = normalize value
191 return (C8.pack name, C8.pack norm)
193 normalize :: String -> String
194 normalize = trimBody . trim isWhiteSpace
196 trimBody = foldr (++) []
197 . map (\ s -> if head s == ' ' then
202 . map (\ c -> if isWhiteSpace c
207 hPutHeaders :: Handle -> Headers -> IO ()
210 mapM_ putH (M.toList hds) >> C8.hPut h (C8.pack "\r\n")
212 putH :: (NCBS, ByteString) -> IO ()
214 = name `seq` value `seq`
215 do C8.hPut h (fromNCBS name)
216 C8.hPut h (C8.pack ": ")
218 C8.hPut h (C8.pack "\r\n")