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