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