8 module Network.HTTP.Lucu.Preprocess
10 , RequestBodyLength(..)
14 import Control.Applicative
15 import Control.Applicative.Unicode
17 import Control.Monad.State.Strict
18 import Data.Ascii (Ascii)
19 import qualified Data.Ascii as A
20 import qualified Data.ByteString.Char8 as C8
21 import Data.CaseInsensitive (CI)
22 import qualified Data.CaseInsensitive as CI
23 import Data.Convertible.Base
24 import Data.Convertible.Instances.Text ()
26 import Data.Text (Text)
27 import qualified Data.Text.Encoding as T
28 import Network.HTTP.Lucu.Headers
29 import Network.HTTP.Lucu.HttpVersion
30 import Network.HTTP.Lucu.Request
31 import Network.HTTP.Lucu.Response.StatusCode
34 import Prelude.Unicode
39 , arInitialStatus ∷ !SomeStatusCode
40 , arWillChunkBody ∷ !Bool
42 , arExpectedContinue ∷ !Bool
43 , arReqBodyLength ∷ !(Maybe RequestBodyLength)
46 data RequestBodyLength
51 preprocess ∷ CI Text → PortNumber → Bool → Request → AugmentedRequest
52 preprocess localHost localPort isSSL req@(Request {..})
53 = execState go initialAR
55 initialAR ∷ AugmentedRequest
56 initialAR = AugmentedRequest {
58 , arInitialStatus = fromStatusCode OK
59 , arWillChunkBody = False
61 , arExpectedContinue = False
62 , arReqBodyLength = Nothing
64 go ∷ State AugmentedRequest ()
65 go = do examineHttpVersion
68 examineAuthority localHost localPort
72 setRequest ∷ Request → State AugmentedRequest ()
74 = modify $ \ar → ar { arRequest = req }
76 setStatus ∷ StatusCode sc ⇒ sc → State AugmentedRequest ()
78 = modify $ \ar → ar { arInitialStatus = fromStatusCode sc }
80 setWillClose ∷ Bool → State AugmentedRequest ()
82 = modify $ \ar → ar { arWillClose = b }
84 setBodyLength ∷ Maybe RequestBodyLength → State AugmentedRequest ()
86 = modify $ \ar → ar { arReqBodyLength = len }
88 examineHttpVersion ∷ State AugmentedRequest ()
90 = do req ← gets arRequest
91 case reqVersion req of
92 -- HTTP/1.0 requests can't Keep-Alive.
96 → modify $ \ar → ar { arWillChunkBody = True }
97 _ → do setStatus HTTPVersionNotSupported
100 examineMethod ∷ State AugmentedRequest ()
102 = do req ← gets arRequest
103 case reqMethod req of
109 _ → setStatus NotImplemented
111 examineScheme ∷ Bool → State AugmentedRequest ()
113 = do req ← gets arRequest
114 when (null ∘ uriScheme $ reqURI req) $
115 let uri' = (reqURI req) {
116 uriScheme = if isSSL then
121 req' = req { reqURI = uri' }
125 examineAuthority ∷ CI Text → PortNumber → State AugmentedRequest ()
126 examineAuthority localHost localPort
127 = do req ← gets arRequest
128 when (isNothing $ uriAuthority $ reqURI req) $
129 case reqVersion req of
130 -- HTTP/1.0 requests have no Host header so complete it
131 -- with the configuration value.
133 → let host = localHost
134 port = case localPort of
135 n | Just n ≡ defaultPort (reqURI req)
137 n → A.unsafeFromString $ ':':show n
138 req' = updateAuthority host port req
141 -- HTTP/1.1 requests MUST have a Host header, but if
142 -- the requested URI has an authority, the value of
143 -- Host header must be ignored. See:
144 -- http://tools.ietf.org/html/rfc2616#section-5.2
146 → case getHeader "Host" req of
148 | isNothing ∘ uriAuthority ∘ reqURI $ req
151 req' = updateAuthority host port req
157 → setStatus BadRequest
158 -- Should never reach here...
159 ver → fail ("internal error: unknown version: " ⧺ show ver)
161 defaultPort ∷ Alternative f ⇒ URI → f PortNumber
162 {-# INLINEABLE defaultPort #-}
163 defaultPort (uriScheme → s)
164 | s ≡ "http:" = pure 80
165 | s ≡ "https:" = pure 443
168 parseHost ∷ Ascii → (CI Text, Ascii)
170 = let (h, p) = C8.break (≡ ':') $ cs hp
171 -- FIXME: should decode punycode here.
172 hText = CI.mk $ T.decodeUtf8 h
173 pAscii = A.unsafeFromByteString p
177 updateAuthority ∷ CI Text → Ascii → Request → Request
178 updateAuthority host port req@(Request {..})
179 = let uri' = reqURI {
180 uriAuthority = Just URIAuth {
182 , uriRegName = cs $ CI.original host
187 req { reqURI = uri' }
189 examineHeaders ∷ State AugmentedRequest ()
191 = do req ← gets arRequest
193 case getCIHeader "Expect" req of
197 → modify $ \ar → ar { arExpectedContinue = True }
199 → setStatus ExpectationFailed
201 case getCIHeader "Transfer-Encoding" req of
207 → setBodyLength $ Just Chunked
209 → setStatus NotImplemented
211 case cs <$> getHeader "Content-Length" req of
213 Just value → case C8.readInt value of
215 | C8.null garbage ∧ len ≥ 0
216 → setBodyLength $ Just $ Fixed len
217 _ → setStatus BadRequest
219 case getCIHeader "Connection" req of
225 examineBodyLength ∷ State AugmentedRequest ()
227 = do req ← gets arRequest
228 len ← gets arReqBodyLength
229 if reqHasBody req then
230 -- POST and PUT requests must have an entity body.
232 $ setStatus LengthRequired
234 -- Other requests must NOT have an entity body.
236 $ setStatus BadRequest