Network/HTTP/Lucu/Parser/Http.hs

   1 {-# LANGUAGE
   2     BangPatterns
   3   , OverloadedStrings
   4   , UnicodeSyntax
   5   #-}
   6 -- |This is an auxiliary parser utilities for parsing things related
   7 -- on HTTP protocol.
   8 --
   9 -- In general you don't have to use this module directly.
  10 module Network.HTTP.Lucu.Parser.Http
  11     ( isCtl
  12     , isText
  13     , isSeparator
  14     , isChar
  15     , isToken
  16     , isSPHT
  17
  18     , listOf
  19
  20     , crlf
  21     , sp
  22     , lws
  23
  24     , token
  25     , separators
  26     , quotedStr
  27     , qvalue
  28
  29     , atMost
  30     )
  31     where
  32 import Control.Applicative
  33 import Control.Applicative.Unicode
  34 import Control.Monad.Unicode
  35 import Data.Ascii (Ascii)
  36 import qualified Data.Ascii as A
  37 import Data.Attoparsec.Char8 as P
  38 import qualified Data.Attoparsec.FastSet as FS
  39 import qualified Data.ByteString.Char8 as BS
  40 import Prelude.Unicode
  41
  42 -- |@'isCtl' c@ is 'Prelude.False' iff @0x20 <= c < 0x7F@.
  43 isCtl ∷ Char → Bool
  44 {-# INLINE isCtl #-}
  45 isCtl c
  46     | c ≤ '\x1f' = True
  47     | c > '\x7f' = True
  48     | otherwise  = False
  49
  50 -- |@'isText'@ is equivalent to @'not' '.' 'isCtl'@
  51 isText ∷ Char → Bool
  52 {-# INLINE isText #-}
  53 isText = (¬) ∘ isCtl
  54
  55 -- |@'isSeparator' c@ is 'Prelude.True' iff c is one of HTTP
  56 -- separators.
  57 isSeparator ∷ Char → Bool
  58 {-# INLINE isSeparator #-}
  59 isSeparator = flip FS.memberChar set
  60     where
  61       {-# NOINLINE set #-}
  62       set = FS.charClass "()<>@,;:\\\"/[]?={}\x20\x09"
  63
  64 -- |@'isChar' c@ is 'Prelude.True' iff @c <= 0x7f@.
  65 isChar ∷ Char → Bool
  66 {-# INLINE isChar #-}
  67 isChar = (≤ '\x7F')
  68
  69 -- |@'isToken' c@ is equivalent to @not ('isCtl' c || 'isSeparator'
  70 -- c)@
  71 isToken ∷ Char → Bool
  72 {-# INLINE isToken #-}
  73 isToken !c
  74     = (¬) (isCtl c ∨ isSeparator c)
  75
  76 -- |@'listOf' p@ is similar to @'sepBy' p ('char' \',\')@ but it
  77 -- allows any occurrences of 'lws' before and after each tokens.
  78 listOf ∷ Parser a → Parser [a]
  79 {-# INLINEABLE listOf #-}
  80 listOf p
  81     = try $
  82       do skipMany lws
  83          sepBy p $ do skipMany lws
  84                       _ <- char ','
  85                       skipMany lws
  86
  87 -- |'token' is similar to @'takeWhile1' 'isToken'@
  88 token ∷ Parser Ascii
  89 {-# INLINE token #-}
  90 token = A.unsafeFromByteString <$> takeWhile1 isToken
  91
  92 -- |The CRLF: 0x0D 0x0A.
  93 crlf ∷ Parser ()
  94 {-# INLINE crlf #-}
  95 crlf = string "\x0D\x0A" ≫ return ()
  96
  97 -- |The SP: 0x20.
  98 sp ∷ Parser ()
  99 {-# INLINE sp #-}
 100 sp = char '\x20' ≫ return ()
 101
 102 -- |HTTP LWS: crlf? (sp | ht)+
 103 lws ∷ Parser ()
 104 {-# INLINEABLE lws #-}
 105 lws = try $
 106       do option () crlf
 107          _ ← satisfy isSPHT
 108          skipWhile isSPHT
 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 similar to @'takeWhile1' 'isSeparator'@.
 118 separators ∷ Parser Ascii
 119 {-# INLINE separators #-}
 120 separators = A.unsafeFromByteString <$> takeWhile1 isSeparator
 121
 122 -- |'quotedStr' accepts a string surrounded by double quotation
 123 -- marks. Quotes can be escaped by backslashes.
 124 quotedStr ∷ Parser Ascii
 125 {-# INLINEABLE quotedStr #-}
 126 quotedStr = try $
 127             do _  ← char '"'
 128                xs ← P.many (qdtext <|> quotedPair)
 129                _  ← char '"'
 130                return $ A.unsafeFromByteString $ BS.pack xs
 131     where
 132       qdtext ∷ Parser Char
 133       {-# INLINE qdtext #-}
 134       qdtext = satisfy (\c → c ≢ '"' ∧ (¬) (isCtl c))
 135
 136       quotedPair ∷ Parser Char
 137       {-# INLINE quotedPair #-}
 138       quotedPair = char '\\' ≫ satisfy isChar
 139
 140 -- |'qvalue' accepts a so-called qvalue.
 141 qvalue ∷ Parser Double
 142 {-# INLINEABLE qvalue #-}
 143 qvalue = do x  ← char '0'
 144             xs ← option "" $
 145                  do y  ← char '.'
 146                     ys ← atMost 3 digit
 147                     return (y:ys)
 148             return $ read (x:xs)
 149          <|>
 150          do x  ← char '1'
 151             xs ← option "" $
 152                  do y  ← char '.'
 153                     ys ← atMost 3 (char '0')
 154                     return (y:ys)
 155             return $ read (x:xs)
 156
 157 -- |@'atMost' n v@ is like @'P.many' v@ but applies the given action
 158 -- at most @n@ times.
 159 atMost ∷ Alternative f ⇒ Int → f a → f [a]
 160 {-# INLINE atMost #-}
 161 atMost 0 _ = pure []
 162 atMost n v = ( (:) <$> v ⊛ atMost (n-1) v )
 163              <|>
 164              pure []