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           Network.HTTP.Lucu.Parser
  21
  22 -- |@'isCtl' c@ is 'Prelude.False' iff @0x20 <= @c@ < 0x7F@.
  23 isCtl :: Char -> Bool
  24 isCtl c
  25     | c <  '\x1f' = True
  26     | c >= '\x7f' = True
  27     | otherwise   = False
  28
  29 -- |@'isSeparator' c@ is 'Prelude.True' iff c is one of HTTP
  30 -- 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 'Prelude.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 = do _ <- many lws
  70                sepBy p $! do _ <- many lws
  71                              _ <- char ','
  72                              many lws
  73
  74 -- |'token' is equivalent to @'Network.HTTP.Lucu.Parser.many1' $
  75 -- 'Network.HTTP.Lucu.Parser.satisfy' 'isToken'@
  76 token :: Parser String
  77 token = many1 $! satisfy isToken
  78
  79 -- |'lws' is an HTTP LWS: @'Network.HTTP.Lucu.Parser.crlf'?
  80 -- ('Network.HTTP.Lucu.Parser.sp' | 'Network.HTTP.Lucu.Parser.ht')+@
  81 lws :: Parser String
  82 lws = do s  <- option "" crlf
  83          xs <- many1 (sp <|> ht)
  84          return (s ++ xs)
  85
  86 -- |'text' accepts one character which doesn't satisfy 'isCtl'.
  87 text :: Parser Char
  88 text = satisfy (not . isCtl)
  89
  90 -- |'separator' accepts one character which satisfies 'isSeparator'.
  91 separator :: Parser Char
  92 separator = satisfy isSeparator
  93
  94 -- |'quotedStr' accepts a string surrounded by double quotation
  95 -- marks. Quotes can be escaped by backslashes.
  96 quotedStr :: Parser String
  97 quotedStr = do _  <- char '"'
  98                xs <- many (qdtext <|> quotedPair)
  99                _  <- char '"'
 100                return $ foldr (++) "" xs
 101     where
 102       qdtext = do c <- satisfy (/= '"')
 103                   return [c]
 104
 105       quotedPair = do _ <- char '\\'
 106                       c <- satisfy isChar
 107                       return [c]
 108
 109 -- |'qvalue' accepts a so-called qvalue.
 110 qvalue :: Parser Double
 111 qvalue = do x  <- char '0'
 112             xs <- option ""
 113                   $ do y  <- char '.'
 114                        ys <- many digit -- 本當は三文字までに制限
 115                        return (y:ys)
 116             return $ read (x:xs)
 117          <|>
 118          do x  <- char '1'
 119             xs <- option ""
 120                   $ do y  <- char '.'
 121                        ys <- many (char '0') -- 本當は三文字までに制限
 122                        return (y:ys)
 123             return $ read (x:xs)