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
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 #-}
91 sepBy p $ do skipMany lws
95 -- |'token' is similar to @'takeWhile1' 'isToken'@
98 token = A.unsafeFromByteString <$> takeWhile1 isToken
100 -- |The CRLF: 0x0D 0x0A.
103 crlf = string "\x0D\x0A" ≫ return ()
108 sp = char '\x20' ≫ return ()
110 -- |HTTP LWS: crlf? (sp | ht)+
112 {-# INLINEABLE lws #-}
113 lws = do option () crlf
114 _ ← takeWhile1 isSPHT
117 -- |Returns 'True' for SP and HT.
119 {-# INLINE isSPHT #-}
124 -- |@'separators'@ is similar to @'takeWhile1' 'isSeparator'@.
125 separators ∷ Parser Ascii
126 {-# INLINE separators #-}
127 separators = A.unsafeFromByteString <$> takeWhile1 isSeparator
129 -- |'quotedStr' accepts a string surrounded by double quotation
130 -- marks. Quotes can be escaped by backslashes.
131 quotedStr ∷ Parser Ascii
132 {-# INLINEABLE quotedStr #-}
135 xs ← P.many (qdtext <|> quotedPair)
137 return $ A.unsafeFromByteString $ BS.pack xs
140 {-# INLINE qdtext #-}
141 qdtext = satisfy (\c → c ≢ '"' ∧ (¬) (isCtl c))
143 quotedPair ∷ Parser Char
144 {-# INLINE quotedPair #-}
145 quotedPair = char '\\' ≫ satisfy isChar
147 -- |'qvalue' accepts a so-called qvalue.
148 qvalue ∷ Parser Double
149 {-# INLINEABLE qvalue #-}
150 qvalue = do x ← char '0'
160 ys ← atMost 3 (char '0')
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 #-}
169 atMost n v = ( (:) <$> v ⊛ atMost (n-1) v )
176 casChunks ∷ !(S.Seq BS.ByteString)
177 , casLastChunk ∷ !(S.Seq Char)
180 instance Monoid CharAccumState where
188 casChunks = (casChunks a ⊳ lastChunk a) ⋈ casChunks b
191 lastChunk ∷ CharAccumState → BS.ByteString
192 {-# INLINE lastChunk #-}
193 lastChunk = BS.pack ∘ toList ∘ casLastChunk
195 snoc ∷ CharAccumState → Char → CharAccumState
196 {-# INLINEABLE snoc #-}
198 | S.length (casLastChunk cas) ≥ LS.defaultChunkSize
200 casChunks = casChunks cas ⊳ lastChunk cas
201 , casLastChunk = S.singleton c
205 casLastChunk = casLastChunk cas ⊳ c
208 finish ∷ CharAccumState → LS.ByteString
209 {-# INLINEABLE finish #-}
211 = let chunks = toList $ casChunks cas ⊳ lastChunk cas
212 str = LS.fromChunks chunks
216 manyCharsTill ∷ ∀m b. (Monad m, Alternative m)
220 {-# INLINEABLE manyCharsTill #-}
221 manyCharsTill p end = scan (∅)
223 scan ∷ CharAccumState → m LS.ByteString
226 = (end *> pure (finish s))
228 (scan =≪ (snoc s <$> p))