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