data/mime.types

[Lucu.git] / Network / HTTP / Lucu / Parser / Http.hs

diff --git a/Network/HTTP/Lucu/Parser/Http.hs b/Network/HTTP/Lucu/Parser/Http.hs
index 021ced85d9856cef8d48d7ffb3bcef4575854ffa..93fc14d9c80077cf3f2ba63270b215c8fc3f7442 100644 (file)
--- a/Network/HTTP/Lucu/Parser/Http.hs
+++ b/Network/HTTP/Lucu/Parser/Http.hs
@@ -1,7 +1,14 @@
 module Network.HTTP.Lucu.Parser.Http
     ( isCtl       -- Char -> Bool
     , isSeparator -- Char -> Bool
-    , token       -- Parser Char
+    , isChar      -- Char -> Bool
+    , isToken     -- Char -> Bool
+    , listOf      -- Parser a -> Parser [a]
+    , token       -- Parser String
+    , lws         -- Parser String
+    , text        -- Parser Char
+    , separator   -- Parser Char
+    , quotedStr   -- Parser String
     )
     where
 
@@ -13,7 +20,7 @@ import           Network.HTTP.Lucu.Parser
 isCtl :: Char -> Bool
 isCtl c
     | c <  '\x1f' = True
-    | c == '\x7f' = True
+    | c >= '\x7f' = True
     | otherwise  = False
 
 
@@ -21,5 +28,50 @@ isSeparator :: Char -> Bool
 isSeparator c = elem c "()<>@,;:\\\"/[]?={} \t"
 
 
-token :: Parser Char
-token = satisfy (\ c -> not (isCtl c || isSeparator c))
+isChar :: Char -> Bool
+isChar c
+    | c <= '\x7f' = True
+    | otherwise   = False
+
+
+isToken :: Char -> Bool
+isToken c = not (isCtl c || isSeparator c)
+
+
+listOf :: Parser a -> Parser [a]
+listOf p = do many lws
+              sepBy p (do many lws
+                          char ','
+                          many lws)
+
+
+token :: Parser String
+token = many1 $ satisfy isToken
+
+
+lws :: Parser String
+lws = do s  <- option "" crlf
+         xs <- many1 (sp <|> ht)
+         return (s ++ xs)
+
+
+text :: Parser Char
+text = satisfy (\ c -> not (isCtl c))
+
+
+separator :: Parser Char
+separator = satisfy isSeparator
+
+
+quotedStr :: Parser String
+quotedStr = do char '"'
+               xs <- many (qdtext <|> quotedPair)
+               char '"'
+               return $ foldr (++) "" xs
+    where
+      qdtext = do c <- satisfy (/= '"')
+                  return [c]
+
+      quotedPair = do q <- char '\\'
+                      c <- satisfy isChar
+                      return [c]