Network/HTTP/Lucu/Headers.hs

   1 module Network.HTTP.Lucu.Headers
   2     ( Headers
   3     , HasHeaders(..)
   4     , emptyHeaders
   5     , headersP
   6     , hPutHeaders
   7     )
   8     where
   9
  10 import           Data.Char
  11 import           Data.List
  12 import           Network.HTTP.Lucu.Parser
  13 import           Network.HTTP.Lucu.Parser.Http
  14 import           Network.HTTP.Lucu.Utils
  15 import           System.IO
  16
  17 type Headers = [ (String, String) ]
  18
  19 class HasHeaders a where
  20     getHeaders :: a -> Headers
  21     setHeaders :: a -> Headers -> a
  22
  23     getHeader :: String -> a -> Maybe String
  24     getHeader key a
  25         = key `seq` a `seq`
  26           fmap snd $ find (noCaseEq' key . fst) (getHeaders a)
  27
  28     deleteHeader :: String -> a -> a
  29     deleteHeader key a
  30         = key `seq` a `seq`
  31           setHeaders a $ filter (not . noCaseEq' key . fst) (getHeaders a)
  32
  33     addHeader :: String -> String -> a -> a
  34     addHeader key val a
  35         = key `seq` val `seq` a `seq`
  36           setHeaders a $ (getHeaders a) ++ [(key, val)]
  37
  38     setHeader :: String -> String -> a -> a
  39     setHeader key val a
  40         = key `seq` val `seq` a `seq`
  41           let list    = getHeaders a
  42               deleted = filter (not . noCaseEq' key . fst) list
  43               added   = deleted ++ [(key, val)]
  44           in
  45             setHeaders a added
  46
  47 emptyHeaders :: Headers
  48 emptyHeaders = []
  49
  50
  51 {-
  52   message-header = field-name ":" [ field-value ]
  53   field-name     = token
  54   field-value    = *( field-content | LWS )
  55   field-content  = <field-value を構成し、*TEXT あるいは
  56                     token, separators, quoted-string を連結
  57                     したものから成る OCTET>
  58
  59   field-value の先頭および末尾にある LWS は全て削除され、それ以外の
  60   LWS は單一の SP に變換される。
  61 -}
  62 headersP :: Parser Headers
  63 headersP = do xs <- many header
  64               crlf
  65               return xs
  66     where
  67       header :: Parser (String, String)
  68       header = do name <- token
  69                   char ':'
  70                   -- FIXME: これは多少インチキだが、RFC 2616 のこの部分
  71                   -- の記述はひどく曖昧であり、この動作が本當に間違って
  72                   -- ゐるのかどうかも良く分からない。例へば
  73                   -- quoted-string の内部にある空白は纏めていいのか惡い
  74                   -- のか？直勸的には駄目さうに思へるが、そんな記述は見
  75                   -- 付からない。
  76                   contents <- many (lws <|> many1 text)
  77                   crlf
  78                   let value = foldr (++) "" contents
  79                   return (name, normalize value)
  80
  81       normalize :: String -> String
  82       normalize = trimBody . trim isWhiteSpace
  83
  84       trimBody = foldr (++) []
  85                  . map (\ s -> if head s == ' ' then
  86                                    " "
  87                                else
  88                                    s)
  89                  . group
  90                  . map (\ c -> if isWhiteSpace c
  91                                then ' '
  92                                else c)
  93
  94
  95 hPutHeaders :: Handle -> Headers -> IO ()
  96 hPutHeaders h hds
  97     = h `seq` hds `seq`
  98       mapM_ putH hds >> hPutStr h "\r\n"
  99     where
 100       putH :: (String, String) -> IO ()
 101       putH (name, value)
 102           = name `seq` value `seq`
 103             do hPutStr h name
 104                hPutStr h ": "
 105                hPutStr h value
 106                hPutStr h "\r\n"