+{-# LANGUAGE
+ BangPatterns
+ , UnicodeSyntax
+ #-}
+-- |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 'Prelude.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 'Prelude.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 'Prelude.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 = 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 (not . isCtl)
+
+-- |'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 _ <- 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 y <- char '.'
+ ys <- many digit -- 本當は三文字までに制限
+ return (y:ys)
+ return $ read (x:xs)
+ <|>
+ do x <- char '1'
+ xs <- option ""
+ $ do y <- char '.'
+ ys <- many (char '0') -- 本當は三文字までに制限
+ return (y:ys)
+ return $ read (x:xs)