Network/HTTP/Lucu/Headers.hs

   1 module Network.HTTP.Lucu.Headers
   2     ( Headers
   3     , HasHeaders(..)
   4
   5     , noCaseCmp
   6     , noCaseEq
   7
   8     , emptyHeaders
   9     , toHeaders
  10     , fromHeaders
  11
  12     , headersP
  13     , hPutHeaders
  14     )
  15     where
  16
  17 import qualified Data.ByteString as Strict (ByteString)
  18 import           Data.ByteString.Internal (toForeignPtr, w2c, inlinePerformIO)
  19 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
  20 import           Data.Char
  21 import           Data.List
  22 import           Data.Map (Map)
  23 import qualified Data.Map as M
  24 import           Data.Ord
  25 import           Data.Word
  26 import           Foreign.ForeignPtr
  27 import           Foreign.Ptr
  28 import           Foreign.Storable
  29 import           Network.HTTP.Lucu.HandleLike
  30 import           Network.HTTP.Lucu.Parser
  31 import           Network.HTTP.Lucu.Parser.Http
  32 import           Network.HTTP.Lucu.Utils
  33
  34 type Headers = Map NCBS Strict.ByteString
  35 newtype NCBS = NCBS Strict.ByteString
  36
  37 toNCBS :: Strict.ByteString -> NCBS
  38 toNCBS = NCBS
  39 {-# INLINE toNCBS #-}
  40
  41 fromNCBS :: NCBS -> Strict.ByteString
  42 fromNCBS (NCBS x) = x
  43 {-# INLINE fromNCBS #-}
  44
  45 instance Eq NCBS where
  46     (NCBS a) == (NCBS b) = a == b
  47
  48 instance Ord NCBS where
  49     (NCBS a) `compare` (NCBS b) = a `noCaseCmp` b
  50
  51 instance Show NCBS where
  52     show (NCBS x) = show x
  53
  54 noCaseCmp :: Strict.ByteString -> Strict.ByteString -> Ordering
  55 noCaseCmp a b = a `seq` b `seq`
  56                 toForeignPtr a `cmp` toForeignPtr b
  57     where
  58       cmp :: (ForeignPtr Word8, Int, Int) -> (ForeignPtr Word8, Int, Int) -> Ordering
  59       cmp (x1, s1, l1) (x2, s2, l2)
  60           | x1 `seq` s1 `seq` l1 `seq` x2 `seq` s2 `seq` l2 `seq` False = undefined
  61           | l1 == 0  && l2 == 0               = EQ
  62           | x1 == x2 && s1 == s2 && l1 == l2  = EQ
  63           | otherwise
  64               = inlinePerformIO $
  65                 withForeignPtr x1 $ \ p1 ->
  66                 withForeignPtr x2 $ \ p2 ->
  67                 noCaseCmp' (p1 `plusPtr` s1) l1 (p2 `plusPtr` s2) l2
  68
  69
  70 -- もし先頭の文字列が等しければ、短い方が小さい。
  71 noCaseCmp' :: Ptr Word8 -> Int -> Ptr Word8 -> Int -> IO Ordering
  72 noCaseCmp' p1 l1 p2 l2
  73     | p1 `seq` l1 `seq` p2 `seq` l2 `seq` False = undefined
  74     | l1 == 0 && l2 == 0 = return EQ
  75     | l1 == 0            = return LT
  76     |            l2 == 0 = return GT
  77     | otherwise
  78         = do c1 <- peek p1
  79              c2 <- peek p2
  80              case comparing (toLower . w2c) c1 c2 of
  81                EQ -> noCaseCmp' (p1 `plusPtr` 1) (l1 - 1) (p2 `plusPtr` 1) (l2 - 1)
  82                x  -> return x
  83
  84
  85 noCaseEq :: Strict.ByteString -> Strict.ByteString -> Bool
  86 noCaseEq a b = a `seq` b `seq`
  87                toForeignPtr a `cmp` toForeignPtr b
  88     where
  89       cmp :: (ForeignPtr Word8, Int, Int) -> (ForeignPtr Word8, Int, Int) -> Bool
  90       cmp (x1, s1, l1) (x2, s2, l2)
  91           | x1 `seq` s1 `seq` l1 `seq` x2 `seq` s2 `seq` l2 `seq` False = undefined
  92           | l1 /= l2                          = False
  93           | l1 == 0  && l2 == 0               = True
  94           | x1 == x2 && s1 == s2 && l1 == l2  = True
  95           | otherwise
  96               = inlinePerformIO $
  97                 withForeignPtr x1 $ \ p1 ->
  98                 withForeignPtr x2 $ \ p2 ->
  99                 noCaseEq' (p1 `plusPtr` s1) (p2 `plusPtr` s2) l1
 100
 101
 102 noCaseEq' :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool
 103 noCaseEq' p1 p2 l
 104     | p1 `seq` p2 `seq` l `seq` False = undefined
 105     | l == 0    = return True
 106     | otherwise
 107         = do c1 <- peek p1
 108              c2 <- peek p2
 109              if toLower (w2c c1) == toLower (w2c c2) then
 110                  noCaseEq' (p1 `plusPtr` 1) (p2 `plusPtr` 1) (l - 1)
 111                else
 112                  return False
 113
 114
 115 class HasHeaders a where
 116     getHeaders :: a -> Headers
 117     setHeaders :: a -> Headers -> a
 118
 119     getHeader :: Strict.ByteString -> a -> Maybe Strict.ByteString
 120     getHeader key a
 121         = key `seq` a `seq`
 122           M.lookup (toNCBS key) (getHeaders a)
 123
 124     deleteHeader :: Strict.ByteString -> a -> a
 125     deleteHeader key a
 126         = key `seq` a `seq`
 127           setHeaders a $ M.delete (toNCBS key) (getHeaders a)
 128
 129     setHeader :: Strict.ByteString -> Strict.ByteString -> a -> a
 130     setHeader key val a
 131         = key `seq` val `seq` a `seq`
 132           setHeaders a $ M.insert (toNCBS key) val (getHeaders a)
 133
 134
 135 emptyHeaders :: Headers
 136 emptyHeaders = M.empty
 137
 138
 139 toHeaders :: [(Strict.ByteString, Strict.ByteString)] -> Headers
 140 toHeaders xs = mkHeaders xs M.empty
 141
 142
 143 mkHeaders :: [(Strict.ByteString, Strict.ByteString)] -> Headers -> Headers
 144 mkHeaders []              m = m
 145 mkHeaders ((key, val):xs) m = mkHeaders xs $
 146                               case M.lookup (toNCBS key) m of
 147                                 Nothing  -> M.insert (toNCBS key) val m
 148                                 Just old -> M.insert (toNCBS key) (merge old val) m
 149     where
 150       merge :: Strict.ByteString -> Strict.ByteString -> Strict.ByteString
 151       -- カンマ區切りである事を假定する。RFC ではカンマ區切りに出來ない
 152       -- ヘッダは複數個あってはならない事になってゐる。
 153       merge a b
 154           | C8.null a && C8.null b = C8.empty
 155           | C8.null a              = b
 156           |              C8.null b = a
 157           | otherwise              = C8.concat [a, C8.pack ", ", b]
 158
 159
 160 fromHeaders :: Headers -> [(Strict.ByteString, Strict.ByteString)]
 161 fromHeaders hs = [(fromNCBS a, b) | (a, b) <- M.toList hs]
 162
 163
 164 {-
 165   message-header = field-name ":" [ field-value ]
 166   field-name     = token
 167   field-value    = *( field-content | LWS )
 168   field-content  = <field-value を構成し、*TEXT あるいは
 169                     token, separators, quoted-string を連結
 170                     したものから成る OCTET>
 171
 172   field-value の先頭および末尾にある LWS は全て削除され、それ以外の
 173   LWS は單一の SP に變換される。
 174 -}
 175 headersP :: Parser Headers
 176 headersP = do xs <- many header
 177               crlf
 178               return $! toHeaders xs
 179     where
 180       header :: Parser (Strict.ByteString, Strict.ByteString)
 181       header = do name <- token
 182                   char ':'
 183                   -- FIXME: これは多少インチキだが、RFC 2616 のこの部分
 184                   -- の記述はひどく曖昧であり、この動作が本當に間違って
 185                   -- ゐるのかどうかも良く分からない。例へば
 186                   -- quoted-string の内部にある空白は纏めていいのか惡い
 187                   -- のか？直勸的には駄目さうに思へるが、そんな記述は見
 188                   -- 付からない。
 189                   contents <- many (lws <|> many1 text)
 190                   crlf
 191                   let value = foldr (++) "" contents
 192                       norm  = normalize value
 193                   return (C8.pack name, C8.pack norm)
 194
 195       normalize :: String -> String
 196       normalize = trimBody . trim isWhiteSpace
 197
 198       trimBody = concat
 199                  . map (\ s -> if head s == ' ' then
 200                                    " "
 201                                else
 202                                    s)
 203                  . group
 204                  . map (\ c -> if isWhiteSpace c
 205                                then ' '
 206                                else c)
 207
 208
 209 hPutHeaders :: HandleLike h => h -> Headers -> IO ()
 210 hPutHeaders h hds
 211     = h `seq` hds `seq`
 212       mapM_ putH (M.toList hds) >> hPutBS h (C8.pack "\r\n")
 213     where
 214       putH :: (NCBS, Strict.ByteString) -> IO ()
 215       putH (name, value)
 216           = name `seq` value `seq`
 217             do hPutBS h (fromNCBS name)
 218                hPutBS h (C8.pack ": ")
 219                hPutBS h value
 220                hPutBS h (C8.pack "\r\n")