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     = try $
  91       do skipMany lws
  92          sepBy p $ do skipMany lws
  93                       _ <- char ','
  94                       skipMany lws
  95
  96 -- |'token' is similar to @'takeWhile1' 'isToken'@
  97 token ∷ Parser Ascii
  98 {-# INLINE token #-}
  99 token = A.unsafeFromByteString <$> takeWhile1 isToken
 100
 101 -- |The CRLF: 0x0D 0x0A.
 102 crlf ∷ Parser ()
 103 {-# INLINE crlf #-}
 104 crlf = string "\x0D\x0A" ≫ return ()
 105
 106 -- |The SP: 0x20.
 107 sp ∷ Parser ()
 108 {-# INLINE sp #-}
 109 sp = char '\x20' ≫ return ()
 110
 111 -- |HTTP LWS: crlf? (sp | ht)+
 112 lws ∷ Parser ()
 113 {-# INLINEABLE lws #-}
 114 lws = try $
 115       do option () crlf
 116          _ ← satisfy isSPHT
 117          skipWhile isSPHT
 118
 119 -- |Returns 'True' for SP and HT.
 120 isSPHT ∷ Char → Bool
 121 {-# INLINE isSPHT #-}
 122 isSPHT '\x20' = True
 123 isSPHT '\x09' = True
 124 isSPHT _      = False
 125
 126 -- |@'separators'@ is similar to @'takeWhile1' 'isSeparator'@.
 127 separators ∷ Parser Ascii
 128 {-# INLINE separators #-}
 129 separators = A.unsafeFromByteString <$> takeWhile1 isSeparator
 130
 131 -- |'quotedStr' accepts a string surrounded by double quotation
 132 -- marks. Quotes can be escaped by backslashes.
 133 quotedStr ∷ Parser Ascii
 134 {-# INLINEABLE quotedStr #-}
 135 quotedStr = try $
 136             do _  ← char '"'
 137                xs ← P.many (qdtext <|> quotedPair)
 138                _  ← char '"'
 139                return $ A.unsafeFromByteString $ BS.pack xs
 140     where
 141       qdtext ∷ Parser Char
 142       {-# INLINE qdtext #-}
 143       qdtext = satisfy (\c → c ≢ '"' ∧ (¬) (isCtl c))
 144
 145       quotedPair ∷ Parser Char
 146       {-# INLINE quotedPair #-}
 147       quotedPair = char '\\' ≫ satisfy isChar
 148
 149 -- |'qvalue' accepts a so-called qvalue.
 150 qvalue ∷ Parser Double
 151 {-# INLINEABLE qvalue #-}
 152 qvalue = do x  ← char '0'
 153             xs ← option "" $
 154                  do y  ← char '.'
 155                     ys ← atMost 3 digit
 156                     return (y:ys)
 157             return $ read (x:xs)
 158          <|>
 159          do x  ← char '1'
 160             xs ← option "" $
 161                  do y  ← char '.'
 162                     ys ← atMost 3 (char '0')
 163                     return (y:ys)
 164             return $ read (x:xs)
 165
 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 #-}
 170 atMost 0 _ = pure []
 171 atMost n v = ( (:) <$> v ⊛ atMost (n-1) v )
 172              <|>
 173              pure []
 174
 175
 176 data CharAccumState
 177     = CharAccumState {
 178         casChunks    ∷ !(S.Seq BS.ByteString)
 179       , casLastChunk ∷ !(S.Seq Char)
 180       }
 181
 182 instance Monoid CharAccumState where
 183     mempty
 184         = CharAccumState {
 185             casChunks    = (∅)
 186           , casLastChunk = (∅)
 187           }
 188     mappend a b
 189         = b {
 190             casChunks = (casChunks a ⊳ lastChunk a) ⋈ casChunks b
 191           }
 192
 193 lastChunk ∷ CharAccumState → BS.ByteString
 194 {-# INLINE lastChunk #-}
 195 lastChunk = BS.pack ∘ toList ∘ casLastChunk
 196
 197 snoc ∷ CharAccumState → Char → CharAccumState
 198 {-# INLINEABLE snoc #-}
 199 snoc cas c
 200     | S.length (casLastChunk cas) ≥ LS.defaultChunkSize
 201         = cas {
 202             casChunks    = casChunks cas ⊳ lastChunk cas
 203           , casLastChunk = S.singleton c
 204           }
 205     | otherwise
 206         = cas {
 207             casLastChunk = casLastChunk cas ⊳ c
 208           }
 209
 210 finish ∷ CharAccumState → LS.ByteString
 211 {-# INLINEABLE finish #-}
 212 finish cas
 213     = let chunks = toList $ casChunks cas ⊳ lastChunk cas
 214           str    = LS.fromChunks chunks
 215       in
 216         str
 217
 218 manyCharsTill ∷ ∀m b. (Monad m, Alternative m)
 219               ⇒ m Char
 220               → m b
 221               → m LS.ByteString
 222 {-# INLINEABLE manyCharsTill #-}
 223 manyCharsTill p end = scan (∅)
 224     where
 225       scan ∷ CharAccumState → m LS.ByteString
 226       {-# INLINE scan #-}
 227       scan s
 228           = (end *> pure (finish s))
 229             <|>
 230             (scan =≪ (snoc s <$> p))