]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/Parser/Http.hs
Merge branch 'convertible'
[Lucu.git] / Network / HTTP / Lucu / Parser / Http.hs
1 {-# LANGUAGE
2     OverloadedStrings
3   , UnicodeSyntax
4   #-}
5 -- |This is an auxiliary parser utilities for parsing things related
6 -- on HTTP protocol.
7 --
8 -- In general you don't have to use this module directly.
9 module Network.HTTP.Lucu.Parser.Http
10     ( isCtl
11     , isText
12     , isSeparator
13     , isChar
14     , isToken
15     , isSPHT
16
17     , listOf
18
19     , crlf
20     , sp
21     , lws
22
23     , token
24     , separators
25     , quotedStr
26     , qvalue
27     )
28     where
29 import Control.Applicative
30 import Control.Monad
31 import Data.Ascii (Ascii)
32 import qualified Data.Ascii as A
33 import Data.Attoparsec.Char8
34 import qualified Data.ByteString.Char8 as BS
35 import Network.HTTP.Lucu.Parser
36 import Prelude.Unicode
37
38 -- |@'isCtl' c@ returns 'False' iff @0x20 <= c < 0x7F@.
39 isCtl ∷ Char → Bool
40 {-# INLINE isCtl #-}
41 isCtl c
42     | c ≤ '\x1f' = True
43     | c > '\x7f' = True
44     | otherwise  = False
45
46 -- |@'isText'@ is equivalent to @'not' '.' 'isCtl'@
47 isText ∷ Char → Bool
48 {-# INLINE isText #-}
49 isText = (¬) ∘ isCtl
50
51 -- |@'isSeparator' c@ returns 'True' iff c is one of the HTTP
52 -- separators.
53 isSeparator ∷ Char → Bool
54 {-# INLINE isSeparator #-}
55 isSeparator = inClass "()<>@,;:\\\"/[]?={}\x20\x09"
56
57 -- |@'isChar' c@ returns 'True' iff @c <= 0x7f@.
58 isChar ∷ Char → Bool
59 {-# INLINE isChar #-}
60 isChar = (≤ '\x7F')
61
62 -- |@'isToken' c@ is equivalent to @not ('isCtl' c '||' 'isSeparator'
63 -- c)@
64 isToken ∷ Char → Bool
65 {-# INLINE isToken #-}
66 isToken c = (¬) (isCtl c ∨ isSeparator c)
67
68 -- |@'listOf' p@ is similar to @'sepBy' p ('char' \',\')@ but it
69 -- allows any occurrences of 'lws' before and after each tokens.
70 listOf ∷ Parser a → Parser [a]
71 {-# INLINEABLE listOf #-}
72 listOf p
73     = do skipMany lws
74          p `sepBy` do skipMany lws
75                       void $ char ','
76                       skipMany lws
77       <?>
78       "listOf"
79
80 -- |'token' is almost the same as @'takeWhile1' 'isToken'@
81 token ∷ Parser Ascii
82 {-# INLINE token #-}
83 token = (A.unsafeFromByteString <$> takeWhile1 isToken)
84         <?>
85         "token"
86
87 -- |The CRLF: 0x0D 0x0A.
88 crlf ∷ Parser ()
89 {-# INLINE crlf #-}
90 crlf = (string "\x0D\x0A" *> return ())
91        <?>
92        "crlf"
93
94 -- |The SP: 0x20.
95 sp ∷ Parser ()
96 {-# INLINE sp #-}
97 sp = char '\x20' *> return ()
98
99 -- |HTTP LWS: crlf? (sp | ht)+
100 lws ∷ Parser ()
101 {-# INLINEABLE lws #-}
102 lws = (option () crlf *> void (takeWhile1 isSPHT))
103       <?>
104       "lws"
105
106 -- |Returns 'True' for SP and HT.
107 isSPHT ∷ Char → Bool
108 {-# INLINE isSPHT #-}
109 isSPHT '\x20' = True
110 isSPHT '\x09' = True
111 isSPHT _      = False
112
113 -- |@'separators'@ is almost the same as @'takeWhile1' 'isSeparator'@.
114 separators ∷ Parser Ascii
115 {-# INLINE separators #-}
116 separators = (A.unsafeFromByteString <$> takeWhile1 isSeparator)
117              <?>
118              "separators"
119
120 -- |'quotedStr' accepts a string surrounded by double quotation
121 -- marks. Quotes can be escaped by backslashes.
122 quotedStr ∷ Parser Ascii
123 {-# INLINEABLE quotedStr #-}
124 quotedStr = do void $ char '"'
125                xs ← many (qdtext <|> quotedPair)
126                void $ char '"'
127                return ∘ A.unsafeFromByteString $ BS.pack xs
128             <?>
129             "quotedStr"
130     where
131       qdtext ∷ Parser Char
132       {-# INLINE qdtext #-}
133       qdtext = satisfy (\c → c ≢ '"' ∧ (¬) (isCtl c))
134                <?>
135                "qdtext"
136
137       quotedPair ∷ Parser Char
138       {-# INLINE quotedPair #-}
139       quotedPair = (char '\\' *> satisfy isChar)
140                    <?>
141                    "quotedPair"
142
143 -- |'qvalue' accepts a so-called qvalue.
144 qvalue ∷ Parser Double
145 {-# INLINEABLE qvalue #-}
146 qvalue = ( do x  ← char '0'
147               xs ← option "" $
148                    do y  ← char '.'
149                       ys ← atMost 3 digit
150                       return (y:ys)
151               return $ read (x:xs)
152            <|>
153            do x  ← char '1'
154               xs ← option "" $
155                    do y  ← char '.'
156                       ys ← atMost 3 (char '0')
157                       return (y:ys)
158               return $ read (x:xs)
159          )
160          <?>
161          "qvalue"