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