Network/HTTP/Lucu/Parser/Http.hs

   1 -- |This is an auxiliary parser utilities for parsing things related
   2 -- on HTTP protocol.
   3 --
   4 -- In general you don't have to use this module directly.
   5 module Network.HTTP.Lucu.Parser.Http
   6     ( isCtl
   7     , isSeparator
   8     , isChar
   9     , isToken
  10     , listOf
  11     , token
  12     , lws
  13     , text
  14     , separator
  15     , quotedStr
  16     , qvalue
  17     )
  18     where
  19
  20 import           Data.List
  21 import           Network.HTTP.Lucu.Parser
  22
  23 -- |@'isCtl' c@ is False iff @0x20 <= @c@ < 0x7F@.
  24 isCtl :: Char -> Bool
  25 isCtl c
  26     | c <  '\x1f' = True
  27     | c >= '\x7f' = True
  28     | otherwise   = False
  29
  30 -- |@'isSeparator' c@ is True iff c is one of HTTP separators.
  31 isSeparator :: Char -> Bool
  32 isSeparator '('  = True
  33 isSeparator ')'  = True
  34 isSeparator '<'  = True
  35 isSeparator '>'  = True
  36 isSeparator '@'  = True
  37 isSeparator ','  = True
  38 isSeparator ';'  = True
  39 isSeparator ':'  = True
  40 isSeparator '\\' = True
  41 isSeparator '"'  = True
  42 isSeparator '/'  = True
  43 isSeparator '['  = True
  44 isSeparator ']'  = True
  45 isSeparator '?'  = True
  46 isSeparator '='  = True
  47 isSeparator '{'  = True
  48 isSeparator '}'  = True
  49 isSeparator ' '  = True
  50 isSeparator '\t' = True
  51 isSeparator _    = False
  52
  53 -- |@'isChar' c@ is True iff @c <= 0x7f@.
  54 isChar :: Char -> Bool
  55 isChar c
  56     | c <= '\x7f' = True
  57     | otherwise   = False
  58
  59 -- |@'isToken' c@ is equivalent to @not ('isCtl' c || 'isSeparator'
  60 -- c)@
  61 isToken :: Char -> Bool
  62 isToken c = c `seq`
  63             not (isCtl c || isSeparator c)
  64
  65 -- |@'listOf' p@ is similar to @'Network.HTTP.Lucu.Parser.sepBy' p
  66 -- ('Network.HTTP.Lucu.Parser.char' \',\')@ but it allows any
  67 -- occurrences of LWS before and after each tokens.
  68 listOf :: Parser a -> Parser [a]
  69 listOf p = p `seq`
  70            do many lws
  71               sepBy p $! do many lws
  72                             char ','
  73                             many lws
  74
  75 -- |'token' is equivalent to @'Network.HTTP.Lucu.Parser.many1' $
  76 -- 'Network.HTTP.Lucu.Parser.satisfy' 'isToken'@
  77 token :: Parser String
  78 token = many1 $! satisfy isToken
  79
  80 -- |'lws' is an HTTP LWS: @'Network.HTTP.Lucu.Parser.crlf'?
  81 -- ('Network.HTTP.Lucu.Parser.sp' | 'Network.HTTP.Lucu.Parser.ht')+@
  82 lws :: Parser String
  83 lws = do s  <- option "" crlf
  84          xs <- many1 (sp <|> ht)
  85          return (s ++ xs)
  86
  87 -- |'text' accepts one character which doesn't satisfy 'isCtl'.
  88 text :: Parser Char
  89 text = satisfy (\ c -> not (isCtl c))
  90
  91 -- |'separator' accepts one character which satisfies 'isSeparator'.
  92 separator :: Parser Char
  93 separator = satisfy isSeparator
  94
  95 -- |'quotedStr' accepts a string surrounded by double quotation
  96 -- marks. Quotes can be escaped by backslashes.
  97 quotedStr :: Parser String
  98 quotedStr = do char '"'
  99                xs <- many (qdtext <|> quotedPair)
 100                char '"'
 101                return $ foldr (++) "" xs
 102     where
 103       qdtext = do c <- satisfy (/= '"')
 104                   return [c]
 105
 106       quotedPair = do q <- char '\\'
 107                       c <- satisfy isChar
 108                       return [c]
 109
 110 -- |'qvalue' accepts a so-called qvalue.
 111 qvalue :: Parser Double
 112 qvalue = do x  <- char '0'
 113             xs <- option ""
 114                   $ do x  <- char '.'
 115                        xs <- many digit -- 本當は三文字までに制限
 116                        return (x:xs)
 117             return $ read (x:xs)
 118          <|>
 119          do x  <- char '1'
 120             xs <- option ""
 121                   $ do x  <- char '.'
 122                        xs <- many (char '0') -- 本當は三文字までに制限
 123                        return (x:xs)
 124             return $ read (x:xs)