Network/HTTP/Lucu/Parser/Http.hs

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