Network/HTTP/Lucu/Headers.hs

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