X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FHeaders.hs;h=ccd514087b2d7a340360c76fdf6dab034cc0d2da;hb=1000bdc46cfe7b3ae550ff24ccea9f440f11b42a;hp=fbab8563852c1efc56e6bab72006257934340938;hpb=9961a721f98b101825ef154a2122c1fc2fa6d1ac;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs
index fbab856..ccd5140 100644
--- a/Network/HTTP/Lucu/Headers.hs
+++ b/Network/HTTP/Lucu/Headers.hs
@@ -1,45 +1,97 @@
 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 key
+    getHeader :: String -> a -> Maybe String
+    getHeader key a
         = fmap snd $ find (noCaseEq key . fst) (getHeaders a)
 
-    deleteHeader :: a -> ByteString -> a
-    deleteHeader a key
+    deleteHeader :: String -> a -> a
+    deleteHeader key a
         = setHeaders a $ filter (not . noCaseEq key . fst) (getHeaders a)
 
-    addHeader :: a -> ByteString -> ByteString -> a
-    addHeader a key val
+    addHeader :: String -> String -> a -> a
+    addHeader key val a
         = setHeaders a $ (getHeaders a) ++ [(key, val)]
 
-    setHeader :: a -> ByteString -> ByteString -> a
-    setHeader 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
 
-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 = 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"