Network/HTTP/Lucu/Parser/Http.hs

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