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 && l1 /= 0 = return LT
  74     | l1 /= 0 && 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 = M.fromList [(toNCBS a, b) | (a, b) <- xs]
 139
 140
 141 fromHeaders :: Headers -> [(ByteString, ByteString)]
 142 fromHeaders hs = [(fromNCBS a, b) | (a, b) <- M.toList hs]
 143
 144
 145 {-
 146   message-header = field-name ":" [ field-value ]
 147   field-name     = token
 148   field-value    = *( field-content | LWS )
 149   field-content  = <field-value を構成し、*TEXT あるいは
 150                     token, separators, quoted-string を連結
 151                     したものから成る OCTET>
 152
 153   field-value の先頭および末尾にある LWS は全て削除され、それ以外の
 154   LWS は單一の SP に變換される。
 155 -}
 156 headersP :: Parser Headers
 157 headersP = do xs <- many header
 158               crlf
 159               return (M.fromList xs)
 160     where
 161       header :: Parser (NCBS, ByteString)
 162       header = do name <- token
 163                   char ':'
 164                   -- FIXME: これは多少インチキだが、RFC 2616 のこの部分
 165                   -- の記述はひどく曖昧であり、この動作が本當に間違って
 166                   -- ゐるのかどうかも良く分からない。例へば
 167                   -- quoted-string の内部にある空白は纏めていいのか惡い
 168                   -- のか？直勸的には駄目さうに思へるが、そんな記述は見
 169                   -- 付からない。
 170                   contents <- many (lws <|> many1 text)
 171                   crlf
 172                   let value = foldr (++) "" contents
 173                       norm  = normalize value
 174                   return (toNCBS $ C8.pack name, C8.pack norm)
 175
 176       normalize :: String -> String
 177       normalize = trimBody . trim isWhiteSpace
 178
 179       trimBody = foldr (++) []
 180                  . map (\ s -> if head s == ' ' then
 181                                    " "
 182                                else
 183                                    s)
 184                  . group
 185                  . map (\ c -> if isWhiteSpace c
 186                                then ' '
 187                                else c)
 188
 189
 190 hPutHeaders :: Handle -> Headers -> IO ()
 191 hPutHeaders h hds
 192     = h `seq` hds `seq`
 193       mapM_ putH (M.toList hds) >> hPutStr h "\r\n"
 194     where
 195       putH :: (NCBS, ByteString) -> IO ()
 196       putH (name, value)
 197           = name `seq` value `seq`
 198             do C8.hPutStr h (fromNCBS name)
 199                C8.hPutStr h (C8.pack ": ")
 200                C8.hPutStr h value
 201                C8.hPutStr h (C8.pack "\r\n")