Network/HTTP/Lucu/Parser/Http.hs

   1 {-# LANGUAGE
   2     BangPatterns
   3   , OverloadedStrings
   4   , ScopedTypeVariables
   5   , UnicodeSyntax
   6   #-}
   7 -- |This is an auxiliary parser utilities for parsing things related
   8 -- on HTTP protocol.
   9 --
  10 -- In general you don't have to use this module directly.
  11 module Network.HTTP.Lucu.Parser.Http
  12     ( isCtl
  13     , isText
  14     , isSeparator
  15     , isChar
  16     , isToken
  17     , isSPHT
  18
  19     , listOf
  20
  21     , crlf
  22     , sp
  23     , lws
  24
  25     , token
  26     , separators
  27     , quotedStr
  28     , qvalue
  29
  30     , atMost
  31     , manyCharsTill
  32     )
  33     where
  34 import Control.Applicative
  35 import Control.Applicative.Unicode hiding ((∅))
  36 import Control.Monad.Unicode
  37 import Data.Ascii (Ascii)
  38 import qualified Data.Ascii as A
  39 import Data.Attoparsec.Char8 as P hiding (scan)
  40 import qualified Data.Attoparsec.FastSet as FS
  41 import qualified Data.ByteString.Char8 as BS
  42 import qualified Data.ByteString.Lazy.Char8 as LS
  43 import qualified Data.ByteString.Lazy.Internal as LS
  44 import Data.Foldable
  45 import Data.Monoid
  46 import Data.Monoid.Unicode
  47 import qualified Data.Sequence as S
  48 import Data.Sequence.Unicode hiding ((∅))
  49 import Prelude.Unicode
  50
  51 -- |@'isCtl' c@ is 'Prelude.False' iff @0x20 <= c < 0x7F@.
  52 isCtl ∷ Char → Bool
  53 {-# INLINE isCtl #-}
  54 isCtl c
  55     | c ≤ '\x1f' = True
  56     | c > '\x7f' = True
  57     | otherwise  = False
  58
  59 -- |@'isText'@ is equivalent to @'not' '.' 'isCtl'@
  60 isText ∷ Char → Bool
  61 {-# INLINE isText #-}
  62 isText = (¬) ∘ isCtl
  63
  64 -- |@'isSeparator' c@ is 'Prelude.True' iff c is one of HTTP
  65 -- separators.
  66 isSeparator ∷ Char → Bool
  67 {-# INLINE isSeparator #-}
  68 isSeparator = flip FS.memberChar set
  69     where
  70       {-# NOINLINE set #-}
  71       set = FS.charClass "()<>@,;:\\\"/[]?={}\x20\x09"
  72
  73 -- |@'isChar' c@ is 'Prelude.True' iff @c <= 0x7f@.
  74 isChar ∷ Char → Bool
  75 {-# INLINE isChar #-}
  76 isChar = (≤ '\x7F')
  77
  78 -- |@'isToken' c@ is equivalent to @not ('isCtl' c || 'isSeparator'
  79 -- c)@
  80 isToken ∷ Char → Bool
  81 {-# INLINE isToken #-}
  82 isToken !c
  83     = (¬) (isCtl c ∨ isSeparator c)
  84
  85 -- |@'listOf' p@ is similar to @'sepBy' p ('char' \',\')@ but it
  86 -- allows any occurrences of 'lws' before and after each tokens.
  87 listOf ∷ Parser a → Parser [a]
  88 {-# INLINEABLE listOf #-}
  89 listOf p
  90     = do skipMany lws
  91          sepBy p $ do skipMany lws
  92                       _ <- char ','
  93                       skipMany lws
  94
  95 -- |'token' is similar to @'takeWhile1' 'isToken'@
  96 token ∷ Parser Ascii
  97 {-# INLINE token #-}
  98 token = A.unsafeFromByteString <$> takeWhile1 isToken
  99
 100 -- |The CRLF: 0x0D 0x0A.
 101 crlf ∷ Parser ()
 102 {-# INLINE crlf #-}
 103 crlf = string "\x0D\x0A" ≫ return ()
 104
 105 -- |The SP: 0x20.
 106 sp ∷ Parser ()
 107 {-# INLINE sp #-}
 108 sp = char '\x20' ≫ return ()
 109
 110 -- |HTTP LWS: crlf? (sp | ht)+
 111 lws ∷ Parser ()
 112 {-# INLINEABLE lws #-}
 113 lws = do option () crlf
 114          _ ← takeWhile1 isSPHT
 115          return ()
 116
 117 -- |Returns 'True' for SP and HT.
 118 isSPHT ∷ Char → Bool
 119 {-# INLINE isSPHT #-}
 120 isSPHT '\x20' = True
 121 isSPHT '\x09' = True
 122 isSPHT _      = False
 123
 124 -- |@'separators'@ is similar to @'takeWhile1' 'isSeparator'@.
 125 separators ∷ Parser Ascii
 126 {-# INLINE separators #-}
 127 separators = A.unsafeFromByteString <$> takeWhile1 isSeparator
 128
 129 -- |'quotedStr' accepts a string surrounded by double quotation
 130 -- marks. Quotes can be escaped by backslashes.
 131 quotedStr ∷ Parser Ascii
 132 {-# INLINEABLE quotedStr #-}
 133 quotedStr = try $
 134             do _  ← char '"'
 135                xs ← P.many (qdtext <|> quotedPair)
 136                _  ← char '"'
 137                return $ A.unsafeFromByteString $ BS.pack xs
 138     where
 139       qdtext ∷ Parser Char
 140       {-# INLINE qdtext #-}
 141       qdtext = satisfy (\c → c ≢ '"' ∧ (¬) (isCtl c))
 142
 143       quotedPair ∷ Parser Char
 144       {-# INLINE quotedPair #-}
 145       quotedPair = char '\\' ≫ satisfy isChar
 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 -- |@'atMost' n v@ is like @'P.many' v@ but applies the given action
 165 -- at most @n@ times.
 166 atMost ∷ Alternative f ⇒ Int → f a → f [a]
 167 {-# INLINE atMost #-}
 168 atMost 0 _ = pure []
 169 atMost n v = ( (:) <$> v ⊛ atMost (n-1) v )
 170              <|>
 171              pure []
 172
 173
 174 data CharAccumState
 175     = CharAccumState {
 176         casChunks    ∷ !(S.Seq BS.ByteString)
 177       , casLastChunk ∷ !(S.Seq Char)
 178       }
 179
 180 instance Monoid CharAccumState where
 181     mempty
 182         = CharAccumState {
 183             casChunks    = (∅)
 184           , casLastChunk = (∅)
 185           }
 186     mappend a b
 187         = b {
 188             casChunks = (casChunks a ⊳ lastChunk a) ⋈ casChunks b
 189           }
 190
 191 lastChunk ∷ CharAccumState → BS.ByteString
 192 {-# INLINE lastChunk #-}
 193 lastChunk = BS.pack ∘ toList ∘ casLastChunk
 194
 195 snoc ∷ CharAccumState → Char → CharAccumState
 196 {-# INLINEABLE snoc #-}
 197 snoc cas c
 198     | S.length (casLastChunk cas) ≥ LS.defaultChunkSize
 199         = cas {
 200             casChunks    = casChunks cas ⊳ lastChunk cas
 201           , casLastChunk = S.singleton c
 202           }
 203     | otherwise
 204         = cas {
 205             casLastChunk = casLastChunk cas ⊳ c
 206           }
 207
 208 finish ∷ CharAccumState → LS.ByteString
 209 {-# INLINEABLE finish #-}
 210 finish cas
 211     = let chunks = toList $ casChunks cas ⊳ lastChunk cas
 212           str    = LS.fromChunks chunks
 213       in
 214         str
 215
 216 manyCharsTill ∷ ∀m b. (Monad m, Alternative m)
 217               ⇒ m Char
 218               → m b
 219               → m LS.ByteString
 220 {-# INLINEABLE manyCharsTill #-}
 221 manyCharsTill p end = scan (∅)
 222     where
 223       scan ∷ CharAccumState → m LS.ByteString
 224       {-# INLINE scan #-}
 225       scan s
 226           = (end *> pure (finish s))
 227             <|>
 228             (scan =≪ (snoc s <$> p))