-- #hide
module Network.HTTP.Lucu.Headers
    ( Headers
    , HasHeaders(..)
    , emptyHeaders
    , headersP
    , hPutHeaders
    )
    where

import           Data.Char
import           Data.List
import           Network.HTTP.Lucu.Parser
import           Network.HTTP.Lucu.Parser.Http
import           Network.HTTP.Lucu.Utils
import           System.IO

type Headers = [ (String, String) ]

class HasHeaders a where
    getHeaders :: a -> Headers
    setHeaders :: a -> Headers -> a

    getHeader :: String -> a -> Maybe String
    getHeader key a
        = fmap snd $ find (noCaseEq key . fst) (getHeaders a)

    deleteHeader :: String -> a -> a
    deleteHeader key a
        = setHeaders a $ filter (not . noCaseEq key . fst) (getHeaders a)

    addHeader :: String -> String -> a -> a
    addHeader key val a
        = setHeaders a $ (getHeaders a) ++ [(key, val)]

    setHeader :: String -> String -> a -> a
    setHeader key val a
        = let list    = getHeaders a
              deleted = filter (not . noCaseEq key . fst) list
              added   = deleted ++ [(key, val)]
          in 
            setHeaders a added

emptyHeaders :: Headers
emptyHeaders = []


{-
  message-header = field-name ":" [ field-value ]
  field-name     = token
  field-value    = *( field-content | LWS )
  field-content  = <field-value を構成し、*TEXT あるいは
                    token, separators, quoted-string を連結
                    したものから成る OCTET>

  field-value の先頭および末尾にある LWS は全て削除され、それ以外の
  LWS は單一の SP に變換される。
-}
headersP :: Parser Headers
headersP = do xs <- many header
              crlf
              return xs
    where
      header :: Parser (String, String)
      header = do name <- token
                  char ':'
                  -- FIXME: これは多少インチキだが、RFC 2616 のこの部分
                  -- の記述はひどく曖昧であり、この動作が本當に間違って
                  -- ゐるのかどうかも良く分からない。例へば
                  -- quoted-string の内部にある空白は纏めていいのか惡い
                  -- のか？直勸的には駄目さうに思へるが、そんな記述は見
                  -- 付からない。
                  contents <- many (lws <|> many1 text)
                  crlf
                  let value = foldr (++) "" contents
                  return (name, normalize value)

      normalize :: String -> String
      normalize = trimBody . trim isWhiteSpace

      trimBody = foldr (++) []
                 . map (\ s -> if head s == ' ' then
                                   " "
                               else
                                   s)
                 . group
                 . map (\ c -> if isWhiteSpace c
                               then ' '
                               else c)


hPutHeaders :: Handle -> Headers -> IO ()
hPutHeaders h hds = mapM_ putH hds >> hPutStr h "\r\n"
    where
      putH (name, value) = do hPutStr h name
                              hPutStr h ": "
                              hPutStr h value
                              hPutStr h "\r\n"