Many improvements: still in early development

[Lucu.git] / Network / HTTP / Lucu / Headers.hs

diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs
index fbab8563852c1efc56e6bab72006257934340938..655252cc4b656c39abcb92252a276ffc1d94e638 100644 (file)
--- a/Network/HTTP/Lucu/Headers.hs
+++ b/Network/HTTP/Lucu/Headers.hs
@@ -1,34 +1,38 @@
 module Network.HTTP.Lucu.Headers
     ( Headers
     , HasHeaders(..)
-    , emptyHeaders   -- Headers
+    , emptyHeaders -- Headers
+    , headersP     -- Parser Headers
+    , hPutHeaders  -- Handle -> Headers -> IO ()
     )
     where
 
-import qualified Data.ByteString.Lazy.Char8 as B
-import           Data.ByteString.Lazy.Char8 (ByteString)
 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 = [ (ByteString, ByteString) ]
+type Headers = [ (String, String) ]
 
 class HasHeaders a where
     getHeaders :: a -> Headers
     setHeaders :: a -> Headers -> a
 
-    getHeader :: a -> ByteString -> Maybe ByteString
+    getHeader :: a -> String -> Maybe String
     getHeader a key
         = fmap snd $ find (noCaseEq key . fst) (getHeaders a)
 
-    deleteHeader :: a -> ByteString -> a
+    deleteHeader :: a -> String -> a
     deleteHeader a key
         = setHeaders a $ filter (not . noCaseEq key . fst) (getHeaders a)
 
-    addHeader :: a -> ByteString -> ByteString -> a
+    addHeader :: a -> String -> String -> a
     addHeader a key val
         = setHeaders a $ (getHeaders a) ++ [(key, val)]
 
-    setHeader :: a -> ByteString -> ByteString -> a
+    setHeader :: a -> String -> String -> a
     setHeader a key val
         = let list    = getHeaders a
               deleted = filter (not . noCaseEq key . fst) list
@@ -36,10 +40,53 @@ class HasHeaders a where
           in 
             setHeaders a added
 
-noCaseEq :: ByteString -> ByteString -> Bool
-noCaseEq a b
-    = (B.map toLower a) == (B.map toLower b)
+emptyHeaders :: Headers
+emptyHeaders = []
 
 
-emptyHeaders :: Headers
-emptyHeaders = []
\ No newline at end of file
+{-
+  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 = nubBy (\ a b -> a == ' ' && b == ' ')
+                 . 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"