Network/HTTP/Lucu/Headers.hs

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