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 = toForeignPtr a `cmp` toForeignPtr b
  54     where
  55       cmp :: (ForeignPtr Word8, Int, Int) -> (ForeignPtr Word8, Int, Int) -> Ordering
  56       cmp (x1, s1, l1) (x2, s2, l2)
  57           | l1 == 0  && l2 == 0               = EQ
  58           | x1 == x2 && s1 == s2 && l1 == l2  = EQ
  59           | otherwise
  60               = inlinePerformIO $
  61                 withForeignPtr x1 $ \ p1 ->
  62                 withForeignPtr x2 $ \ p2 ->
  63                 noCaseCmp' (p1 `plusPtr` s1) l1 (p2 `plusPtr` s2) l2
  64 {-# INLINE noCaseCmp #-}
  65
  66 -- もし先頭の文字列が等しければ、短い方が小さい。
  67 noCaseCmp' :: Ptr Word8 -> Int -> Ptr Word8 -> Int -> IO Ordering
  68 noCaseCmp' p1 l1 p2 l2
  69     | l1 == 0 && l2 == 0 = return EQ
  70     | l1 == 0 && l1 /= 0 = return LT
  71     | l1 /= 0 && l2 == 0 = return GT
  72     | otherwise
  73         = do c1 <- peek p1
  74              c2 <- peek p2
  75              case toLower (w2c c1) `compare` toLower (w2c c2) of
  76                EQ -> noCaseCmp' (p1 `plusPtr` 1) (l1 - 1) (p2 `plusPtr` 1) (l2 - 1)
  77                x  -> return x
  78
  79
  80 noCaseEq :: ByteString -> ByteString -> Bool
  81 noCaseEq a b = toForeignPtr a `cmp` toForeignPtr b
  82     where
  83       cmp :: (ForeignPtr Word8, Int, Int) -> (ForeignPtr Word8, Int, Int) -> Bool
  84       cmp (x1, s1, l1) (x2, s2, l2)
  85           | l1 /= l2                          = False
  86           | l1 == 0  && l2 == 0               = True
  87           | x1 == x2 && s1 == s2 && l1 == l2  = True
  88           | otherwise
  89               = inlinePerformIO $
  90                 withForeignPtr x1 $ \ p1 ->
  91                 withForeignPtr x2 $ \ p2 ->
  92                 noCaseEq' (p1 `plusPtr` s1) (p2 `plusPtr` s2) l1
  93
  94
  95 noCaseEq' :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool
  96 noCaseEq' p1 p2 l
  97     | l == 0    = return True
  98     | otherwise
  99         = do c1 <- peek p1
 100              c2 <- peek p2
 101              if toLower (w2c c1) == toLower (w2c c2) then
 102                  noCaseEq' (p1 `plusPtr` 1) (p2 `plusPtr` 1) (l - 1)
 103                else
 104                  return False
 105
 106
 107 class HasHeaders a where
 108     getHeaders :: a -> Headers
 109     setHeaders :: a -> Headers -> a
 110
 111     getHeader :: ByteString -> a -> Maybe ByteString
 112     getHeader key a
 113         = key `seq` a `seq`
 114           M.lookup (toNCBS key) (getHeaders a)
 115
 116     deleteHeader :: ByteString -> a -> a
 117     deleteHeader key a
 118         = key `seq` a `seq`
 119           setHeaders a $ M.delete (toNCBS key) (getHeaders a)
 120
 121     setHeader :: ByteString -> ByteString -> a -> a
 122     setHeader key val a
 123         = key `seq` val `seq` a `seq`
 124           setHeaders a $ M.insert (toNCBS key) val (getHeaders a)
 125
 126
 127 emptyHeaders :: Headers
 128 emptyHeaders = M.empty
 129
 130
 131 toHeaders :: [(ByteString, ByteString)] -> Headers
 132 toHeaders xs = M.fromList [(toNCBS a, b) | (a, b) <- xs]
 133
 134
 135 fromHeaders :: Headers -> [(ByteString, ByteString)]
 136 fromHeaders hs = [(fromNCBS a, b) | (a, b) <- M.toList hs]
 137
 138
 139 {-
 140   message-header = field-name ":" [ field-value ]
 141   field-name     = token
 142   field-value    = *( field-content | LWS )
 143   field-content  = <field-value を構成し、*TEXT あるいは
 144                     token, separators, quoted-string を連結
 145                     したものから成る OCTET>
 146
 147   field-value の先頭および末尾にある LWS は全て削除され、それ以外の
 148   LWS は單一の SP に變換される。
 149 -}
 150 headersP :: Parser Headers
 151 headersP = do xs <- many header
 152               crlf
 153               return (M.fromList xs)
 154     where
 155       header :: Parser (NCBS, ByteString)
 156       header = do name <- token
 157                   char ':'
 158                   -- FIXME: これは多少インチキだが、RFC 2616 のこの部分
 159                   -- の記述はひどく曖昧であり、この動作が本當に間違って
 160                   -- ゐるのかどうかも良く分からない。例へば
 161                   -- quoted-string の内部にある空白は纏めていいのか惡い
 162                   -- のか？直勸的には駄目さうに思へるが、そんな記述は見
 163                   -- 付からない。
 164                   contents <- many (lws <|> many1 text)
 165                   crlf
 166                   let value = foldr (++) "" contents
 167                       norm  = normalize value
 168                   return (toNCBS $ C8.pack name, C8.pack norm)
 169
 170       normalize :: String -> String
 171       normalize = trimBody . trim isWhiteSpace
 172
 173       trimBody = foldr (++) []
 174                  . map (\ s -> if head s == ' ' then
 175                                    " "
 176                                else
 177                                    s)
 178                  . group
 179                  . map (\ c -> if isWhiteSpace c
 180                                then ' '
 181                                else c)
 182
 183
 184 hPutHeaders :: Handle -> Headers -> IO ()
 185 hPutHeaders h hds
 186     = h `seq` hds `seq`
 187       mapM_ putH (M.toList hds) >> hPutStr h "\r\n"
 188     where
 189       putH :: (NCBS, ByteString) -> IO ()
 190       putH (name, value)
 191           = name `seq` value `seq`
 192             do C8.hPutStr h (fromNCBS name)
 193                C8.hPutStr h (C8.pack ": ")
 194                C8.hPutStr h value
 195                C8.hPutStr h (C8.pack "\r\n")