Added new actions to the Resource.

[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..77dbe7f225bb2b6c3950b497815efa077d6c98b2 100644 (file)
--- a/Network/HTTP/Lucu/Parser/Http.hs
+++ b/Network/HTTP/Lucu/Parser/Http.hs
@@ -1,25 +1,124 @@
+-- |This is an auxiliary parser utilities for parsing things related
+-- on HTTP protocol.
+--
+-- In general you don't have to use this module directly.
 module Network.HTTP.Lucu.Parser.Http
-    ( isCtl       -- Char -> Bool
-    , isSeparator -- Char -> Bool
-    , token       -- Parser Char
+    ( isCtl
+    , isSeparator
+    , isChar
+    , isToken
+    , listOf
+    , token
+    , lws
+    , text
+    , separator
+    , quotedStr
+    , qvalue
     )
     where
 
-import qualified Data.ByteString.Lazy.Char8 as B
-import           Data.ByteString.Lazy.Char8 (ByteString)
 import           Data.List
 import           Network.HTTP.Lucu.Parser
 
+-- |@'isCtl' c@ is False iff @0x20 <= @c@ < 0x7F@.
 isCtl :: Char -> Bool
 isCtl c
     | c <  '\x1f' = True
-    | c == '\x7f' = True
-    | otherwise  = False
-
+    | c >= '\x7f' = True
+    | otherwise   = False
 
+-- |@'isSeparator' c@ is True iff c is one of HTTP separators.
 isSeparator :: Char -> Bool
-isSeparator c = elem c "()<>@,;:\\\"/[]?={} \t"
+isSeparator '('  = True
+isSeparator ')'  = True
+isSeparator '<'  = True
+isSeparator '>'  = True
+isSeparator '@'  = True
+isSeparator ','  = True
+isSeparator ';'  = True
+isSeparator ':'  = True
+isSeparator '\\' = True
+isSeparator '"'  = True
+isSeparator '/'  = True
+isSeparator '['  = True
+isSeparator ']'  = True
+isSeparator '?'  = True
+isSeparator '='  = True
+isSeparator '{'  = True
+isSeparator '}'  = True
+isSeparator ' '  = True
+isSeparator '\t' = True
+isSeparator _    = False
+
+-- |@'isChar' c@ is True iff @c <= 0x7f@.
+isChar :: Char -> Bool
+isChar c
+    | c <= '\x7f' = True
+    | otherwise   = False
+
+-- |@'isToken' c@ is equivalent to @not ('isCtl' c || 'isSeparator'
+-- c)@
+isToken :: Char -> Bool
+isToken c = c `seq`
+            not (isCtl c || isSeparator c)
+
+-- |@'listOf' p@ is similar to @'Network.HTTP.Lucu.Parser.sepBy' p
+-- ('Network.HTTP.Lucu.Parser.char' \',\')@ but it allows any
+-- occurrences of LWS before and after each tokens.
+listOf :: Parser a -> Parser [a]
+listOf p = p `seq`
+           do many lws
+              sepBy p $! do many lws
+                            char ','
+                            many lws
+
+-- |'token' is equivalent to @'Network.HTTP.Lucu.Parser.many1' $
+-- 'Network.HTTP.Lucu.Parser.satisfy' 'isToken'@
+token :: Parser String
+token = many1 $! satisfy isToken
+
+-- |'lws' is an HTTP LWS: @'Network.HTTP.Lucu.Parser.crlf'?
+-- ('Network.HTTP.Lucu.Parser.sp' | 'Network.HTTP.Lucu.Parser.ht')+@
+lws :: Parser String
+lws = do s  <- option "" crlf
+         xs <- many1 (sp <|> ht)
+         return (s ++ xs)
+
+-- |'text' accepts one character which doesn't satisfy 'isCtl'.
+text :: Parser Char
+text = satisfy (\ c -> not (isCtl c))
+
+-- |'separator' accepts one character which satisfies 'isSeparator'.
+separator :: Parser Char
+separator = satisfy isSeparator
+
+-- |'quotedStr' accepts a string surrounded by double quotation
+-- marks. Quotes can be escaped by backslashes.
+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]
 
-token :: Parser Char
-token = satisfy (\ c -> not (isCtl c || isSeparator c))
+-- |'qvalue' accepts a so-called qvalue.
+qvalue :: Parser Double
+qvalue = do x  <- char '0'
+            xs <- option ""
+                  $ do x  <- char '.'
+                       xs <- many digit -- 本當は三文字までに制限
+                       return (x:xs)
+            return $ read (x:xs)
+         <|>
+         do x  <- char '1'
+            xs <- option ""
+                  $ do x  <- char '.'
+                       xs <- many (char '0') -- 本當は三文字までに制限
+                       return (x:xs)
+            return $ read (x:xs)