Network/HTTP/Lucu/Parser/Http.hs

   1 {-# LANGUAGE
   2     OverloadedStrings
   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     , isText
  12     , isSeparator
  13     , isChar
  14     , isToken
  15     , isSPHT
  16
  17     , listOf
  18
  19     , crlf
  20     , sp
  21     , lws
  22
  23     , token
  24     , separators
  25     , quotedStr
  26     , qvalue
  27     )
  28     where
  29 import Control.Applicative
  30 import Control.Monad
  31 import Data.Ascii (Ascii)
  32 import qualified Data.Ascii as A
  33 import Data.Attoparsec.Char8
  34 import qualified Data.ByteString.Char8 as BS
  35 import Network.HTTP.Lucu.Parser
  36 import Prelude.Unicode
  37
  38 -- |@'isCtl' c@ returns 'False' iff @0x20 <= c < 0x7F@.
  39 isCtl ∷ Char → Bool
  40 {-# INLINE isCtl #-}
  41 isCtl c
  42     | c ≤ '\x1f' = True
  43     | c > '\x7f' = True
  44     | otherwise  = False
  45
  46 -- |@'isText'@ is equivalent to @'not' '.' 'isCtl'@
  47 isText ∷ Char → Bool
  48 {-# INLINE isText #-}
  49 isText = (¬) ∘ isCtl
  50
  51 -- |@'isSeparator' c@ returns 'True' iff c is one of the HTTP
  52 -- separators.
  53 isSeparator ∷ Char → Bool
  54 {-# INLINE isSeparator #-}
  55 isSeparator = inClass "()<>@,;:\\\"/[]?={}\x20\x09"
  56
  57 -- |@'isChar' c@ returns 'True' iff @c <= 0x7f@.
  58 isChar ∷ Char → Bool
  59 {-# INLINE isChar #-}
  60 isChar = (≤ '\x7F')
  61
  62 -- |@'isToken' c@ is equivalent to @not ('isCtl' c '||' 'isSeparator'
  63 -- c)@
  64 isToken ∷ Char → Bool
  65 {-# INLINE isToken #-}
  66 isToken c = (¬) (isCtl c ∨ isSeparator c)
  67
  68 -- |@'listOf' p@ is similar to @'sepBy' p ('char' \',\')@ but it
  69 -- allows any occurrences of 'lws' before and after each tokens.
  70 listOf ∷ Parser a → Parser [a]
  71 {-# INLINEABLE listOf #-}
  72 listOf p
  73     = do skipMany lws
  74          p `sepBy` do skipMany lws
  75                       void $ char ','
  76                       skipMany lws
  77       <?>
  78       "listOf"
  79
  80 -- |'token' is almost the same as @'takeWhile1' 'isToken'@
  81 token ∷ Parser Ascii
  82 {-# INLINE token #-}
  83 token = (A.unsafeFromByteString <$> takeWhile1 isToken)
  84         <?>
  85         "token"
  86
  87 -- |The CRLF: 0x0D 0x0A.
  88 crlf ∷ Parser ()
  89 {-# INLINE crlf #-}
  90 crlf = (string "\x0D\x0A" *> return ())
  91        <?>
  92        "crlf"
  93
  94 -- |The SP: 0x20.
  95 sp ∷ Parser ()
  96 {-# INLINE sp #-}
  97 sp = char '\x20' *> return ()
  98
  99 -- |HTTP LWS: crlf? (sp | ht)+
 100 lws ∷ Parser ()
 101 {-# INLINEABLE lws #-}
 102 lws = (option () crlf *> void (takeWhile1 isSPHT))
 103       <?>
 104       "lws"
 105
 106 -- |Returns 'True' for SP and HT.
 107 isSPHT ∷ Char → Bool
 108 {-# INLINE isSPHT #-}
 109 isSPHT '\x20' = True
 110 isSPHT '\x09' = True
 111 isSPHT _      = False
 112
 113 -- |@'separators'@ is almost the same as @'takeWhile1' 'isSeparator'@.
 114 separators ∷ Parser Ascii
 115 {-# INLINE separators #-}
 116 separators = (A.unsafeFromByteString <$> takeWhile1 isSeparator)
 117              <?>
 118              "separators"
 119
 120 -- |'quotedStr' accepts a string surrounded by double quotation
 121 -- marks. Quotes can be escaped by backslashes.
 122 quotedStr ∷ Parser Ascii
 123 {-# INLINEABLE quotedStr #-}
 124 quotedStr = do void $ char '"'
 125                xs ← many (qdtext <|> quotedPair)
 126                void $ char '"'
 127                return ∘ A.unsafeFromByteString $ BS.pack xs
 128             <?>
 129             "quotedStr"
 130     where
 131       qdtext ∷ Parser Char
 132       {-# INLINE qdtext #-}
 133       qdtext = satisfy (\c → c ≢ '"' ∧ (¬) (isCtl c))
 134                <?>
 135                "qdtext"
 136
 137       quotedPair ∷ Parser Char
 138       {-# INLINE quotedPair #-}
 139       quotedPair = (char '\\' *> satisfy isChar)
 140                    <?>
 141                    "quotedPair"
 142
 143 -- |'qvalue' accepts a so-called qvalue.
 144 qvalue ∷ Parser Double
 145 {-# INLINEABLE qvalue #-}
 146 qvalue = ( do x  ← char '0'
 147               xs ← option "" $
 148                    do y  ← char '.'
 149                       ys ← atMost 3 digit
 150                       return (y:ys)
 151               return $ read (x:xs)
 152            <|>
 153            do x  ← char '1'
 154               xs ← option "" $
 155                    do y  ← char '.'
 156                       ys ← atMost 3 (char '0')
 157                       return (y:ys)
 158               return $ read (x:xs)
 159          )
 160          <?>
 161          "qvalue"