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 'Prelude.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 'Prelude.True' iff c is one of HTTP
  31 -- separators.
  32 isSeparator :: Char -> Bool
  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 ' '  = True
  51 isSeparator '\t' = True
  52 isSeparator _    = False
  53
  54 -- |@'isChar' c@ is 'Prelude.True' iff @c <= 0x7f@.
  55 isChar :: Char -> Bool
  56 isChar c
  57     | c <= '\x7f' = True
  58     | otherwise   = False
  59
  60 -- |@'isToken' c@ is equivalent to @not ('isCtl' c || 'isSeparator'
  61 -- c)@
  62 isToken :: Char -> Bool
  63 isToken c = c `seq`
  64             not (isCtl c || isSeparator c)
  65
  66 -- |@'listOf' p@ is similar to @'Network.HTTP.Lucu.Parser.sepBy' p
  67 -- ('Network.HTTP.Lucu.Parser.char' \',\')@ but it allows any
  68 -- occurrences of LWS before and after each tokens.
  69 listOf :: Parser a -> Parser [a]
  70 listOf p = p `seq`
  71            do many lws
  72               sepBy p $! do many lws
  73                             char ','
  74                             many lws
  75
  76 -- |'token' is equivalent to @'Network.HTTP.Lucu.Parser.many1' $
  77 -- 'Network.HTTP.Lucu.Parser.satisfy' 'isToken'@
  78 token :: Parser String
  79 token = many1 $! satisfy isToken
  80
  81 -- |'lws' is an HTTP LWS: @'Network.HTTP.Lucu.Parser.crlf'?
  82 -- ('Network.HTTP.Lucu.Parser.sp' | 'Network.HTTP.Lucu.Parser.ht')+@
  83 lws :: Parser String
  84 lws = do s  <- option "" crlf
  85          xs <- many1 (sp <|> ht)
  86          return (s ++ xs)
  87
  88 -- |'text' accepts one character which doesn't satisfy 'isCtl'.
  89 text :: Parser Char
  90 text = satisfy (\ c -> not (isCtl c))
  91
  92 -- |'separator' accepts one character which satisfies 'isSeparator'.
  93 separator :: Parser Char
  94 separator = satisfy isSeparator
  95
  96 -- |'quotedStr' accepts a string surrounded by double quotation
  97 -- marks. Quotes can be escaped by backslashes.
  98 quotedStr :: Parser String
  99 quotedStr = do char '"'
 100                xs <- many (qdtext <|> quotedPair)
 101                char '"'
 102                return $ foldr (++) "" xs
 103     where
 104       qdtext = do c <- satisfy (/= '"')
 105                   return [c]
 106
 107       quotedPair = do char '\\'
 108                       c <- satisfy isChar
 109                       return [c]
 110
 111 -- |'qvalue' accepts a so-called qvalue.
 112 qvalue :: Parser Double
 113 qvalue = do x  <- char '0'
 114             xs <- option ""
 115                   $ do y  <- char '.'
 116                        ys <- many digit -- 本當は三文字までに制限
 117                        return (y:ys)
 118             return $ read (x:xs)
 119          <|>
 120          do x  <- char '1'
 121             xs <- option ""
 122                   $ do y  <- char '.'
 123                        ys <- many (char '0') -- 本當は三文字までに制限
 124                        return (y:ys)
 125             return $ read (x:xs)