7 -- |This is an auxiliary parser utilities for parsing things related
10 -- In general you don't have to use this module directly.
11 module Network.HTTP.Lucu.Parser.Http
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 qualified Data.Foldable as F
46 import Data.Monoid.Unicode
47 import qualified Data.Sequence as S
48 import Data.Sequence.Unicode hiding ((∅))
49 import Prelude.Unicode
51 -- |@'isCtl' c@ is 'Prelude.False' iff @0x20 <= c < 0x7F@.
59 -- |@'isText'@ is equivalent to @'not' '.' 'isCtl'@
64 -- |@'isSeparator' c@ is 'Prelude.True' iff c is one of HTTP
66 isSeparator ∷ Char → Bool
67 {-# INLINE isSeparator #-}
68 isSeparator = flip FS.memberChar set
71 set = FS.charClass "()<>@,;:\\\"/[]?={}\x20\x09"
73 -- |@'isChar' c@ is 'Prelude.True' iff @c <= 0x7f@.
78 -- |@'isToken' c@ is equivalent to @not ('isCtl' c || 'isSeparator'
81 {-# INLINE isToken #-}
83 = (¬) (isCtl c ∨ isSeparator c)
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 #-}
92 sepBy p $ do skipMany lws
96 -- |'token' is similar to @'takeWhile1' 'isToken'@
99 token = A.unsafeFromByteString <$> takeWhile1 isToken
101 -- |The CRLF: 0x0D 0x0A.
104 crlf = string "\x0D\x0A" ≫ return ()
109 sp = char '\x20' ≫ return ()
111 -- |HTTP LWS: crlf? (sp | ht)+
113 {-# INLINEABLE lws #-}
119 -- |Returns 'True' for SP and HT.
121 {-# INLINE isSPHT #-}
126 -- |@'separators'@ is similar to @'takeWhile1' 'isSeparator'@.
127 separators ∷ Parser Ascii
128 {-# INLINE separators #-}
129 separators = A.unsafeFromByteString <$> takeWhile1 isSeparator
131 -- |'quotedStr' accepts a string surrounded by double quotation
132 -- marks. Quotes can be escaped by backslashes.
133 quotedStr ∷ Parser Ascii
134 {-# INLINEABLE quotedStr #-}
137 xs ← P.many (qdtext <|> quotedPair)
139 return $ A.unsafeFromByteString $ BS.pack xs
142 {-# INLINE qdtext #-}
143 qdtext = satisfy (\c → c ≢ '"' ∧ (¬) (isCtl c))
145 quotedPair ∷ Parser Char
146 {-# INLINE quotedPair #-}
147 quotedPair = char '\\' ≫ satisfy isChar
149 -- |'qvalue' accepts a so-called qvalue.
150 qvalue ∷ Parser Double
151 {-# INLINEABLE qvalue #-}
152 qvalue = do x ← char '0'
162 ys ← atMost 3 (char '0')
166 -- |@'atMost' n v@ is like @'P.many' v@ but applies the given action
167 -- at most @n@ times.
168 atMost ∷ Alternative f ⇒ Int → f a → f [a]
169 {-# INLINE atMost #-}
171 atMost n v = ( (:) <$> v ⊛ atMost (n-1) v )
178 casChunks ∷ !(S.Seq BS.ByteString)
179 , casLastChunk ∷ !(S.Seq Char)
182 instance Monoid CharAccumState where
190 casChunks = (casChunks a ⊳ lastChunk a) ⋈ casChunks b
193 lastChunk ∷ CharAccumState → BS.ByteString
194 {-# INLINE lastChunk #-}
195 lastChunk = BS.pack ∘ F.toList ∘ casLastChunk
197 snoc ∷ CharAccumState → Char → CharAccumState
198 {-# INLINEABLE snoc #-}
200 | S.length (casLastChunk cas) ≥ LS.defaultChunkSize
202 casChunks = casChunks cas ⊳ lastChunk cas
203 , casLastChunk = S.singleton c
207 casLastChunk = casLastChunk cas ⊳ c
210 finish ∷ CharAccumState → LS.ByteString
211 {-# INLINEABLE finish #-}
213 = let chunks = F.toList $ casChunks cas ⊳ lastChunk cas
214 str = LS.fromChunks chunks
218 manyCharsTill ∷ ∀m b. (Monad m, Alternative m)
222 {-# INLINEABLE manyCharsTill #-}
223 manyCharsTill p end = scan (∅)
225 scan ∷ CharAccumState → m LS.ByteString
228 = (end *> pure (finish s))
230 (scan =≪ (snoc s <$> p))