Moved hidden modules from Exposed-Modules to Other-Modules.

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

diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs
index fbab8563852c1efc56e6bab72006257934340938..65a4940026d5b626d4a11bbec50449d101745256 100644 (file)
--- a/Network/HTTP/Lucu/Headers.hs
+++ b/Network/HTTP/Lucu/Headers.hs
@@ -1,45 +1,106 @@
 module Network.HTTP.Lucu.Headers
     ( Headers
     , HasHeaders(..)
-    , emptyHeaders   -- Headers
+    , emptyHeaders
+    , headersP
+    , hPutHeaders
     )
     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
-        = fmap snd $ find (noCaseEq key . fst) (getHeaders a)
+    getHeader :: String -> a -> Maybe String
+    getHeader key a
+        = key `seq` a `seq`
+          fmap snd $ find (noCaseEq' key . fst) (getHeaders a)
 
-    deleteHeader :: a -> ByteString -> a
-    deleteHeader a key
-        = setHeaders a $ filter (not . noCaseEq key . fst) (getHeaders a)
+    deleteHeader :: String -> a -> a
+    deleteHeader key a
+        = key `seq` a `seq`
+          setHeaders a $ filter (not . noCaseEq' key . fst) (getHeaders a)
 
-    addHeader :: a -> ByteString -> ByteString -> a
-    addHeader a key val
-        = setHeaders a $ (getHeaders a) ++ [(key, val)]
+    addHeader :: String -> String -> a -> a
+    addHeader key val a
+        = key `seq` val `seq` a `seq`
+          setHeaders a $ (getHeaders a) ++ [(key, val)]
 
-    setHeader :: a -> ByteString -> ByteString -> a
-    setHeader a key val
-        = let list    = getHeaders a
-              deleted = filter (not . noCaseEq key . fst) list
+    setHeader :: String -> String -> a -> a
+    setHeader key val a
+        = key `seq` val `seq` a `seq`
+          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
+    = h `seq` hds `seq`
+      mapM_ putH hds >> hPutStr h "\r\n"
+    where
+      putH :: (String, String) -> IO ()
+      putH (name, value)
+          = name `seq` value `seq`
+            do hPutStr h name
+               hPutStr h ": "
+               hPutStr h value
+               hPutStr h "\r\n"