7 module Network.HTTP.Lucu.Preprocess
9 , RequestBodyLength(..)
13 import Control.Applicative
15 import Control.Monad.State.Strict
16 import Data.Ascii (Ascii)
17 import qualified Data.Ascii as A
18 import qualified Data.ByteString.Char8 as C8
19 import Data.CaseInsensitive (CI)
20 import qualified Data.CaseInsensitive as CI
21 import Data.Convertible.Base
22 import Data.Convertible.Instances.Text ()
24 import Data.Text (Text)
25 import qualified Data.Text.Encoding as T
26 import Network.HTTP.Lucu.Headers
27 import Network.HTTP.Lucu.HttpVersion
28 import Network.HTTP.Lucu.Request
29 import Network.HTTP.Lucu.Response.StatusCode
32 import Prelude.Unicode
37 , arInitialStatus ∷ !SomeStatusCode
38 , arWillChunkBody ∷ !Bool
40 , arExpectedContinue ∷ !Bool
41 , arReqBodyLength ∷ !(Maybe RequestBodyLength)
44 data RequestBodyLength
49 preprocess ∷ CI Text → PortNumber → Request → AugmentedRequest
50 preprocess localHost localPort req@(Request {..})
51 = execState go initialAR
53 initialAR ∷ AugmentedRequest
54 initialAR = AugmentedRequest {
56 , arInitialStatus = fromStatusCode OK
57 , arWillChunkBody = False
59 , arExpectedContinue = False
60 , arReqBodyLength = Nothing
62 go ∷ State AugmentedRequest ()
63 go = do examineHttpVersion
65 examineAuthority localHost localPort
69 setRequest ∷ Request → State AugmentedRequest ()
71 = modify $ \ar → ar { arRequest = req }
73 setStatus ∷ StatusCode sc ⇒ sc → State AugmentedRequest ()
75 = modify $ \ar → ar { arInitialStatus = fromStatusCode sc }
77 setWillClose ∷ Bool → State AugmentedRequest ()
79 = modify $ \ar → ar { arWillClose = b }
81 setBodyLength ∷ Maybe RequestBodyLength → State AugmentedRequest ()
83 = modify $ \ar → ar { arReqBodyLength = len }
85 examineHttpVersion ∷ State AugmentedRequest ()
87 = do req ← gets arRequest
88 case reqVersion req of
89 -- HTTP/1.0 requests can't Keep-Alive.
93 → modify $ \ar → ar { arWillChunkBody = True }
94 _ → do setStatus HTTPVersionNotSupported
97 examineMethod ∷ State AugmentedRequest ()
99 = do req ← gets arRequest
100 case reqMethod req of
106 _ → setStatus NotImplemented
108 examineAuthority ∷ CI Text → PortNumber → State AugmentedRequest ()
109 examineAuthority localHost localPort
110 = do req ← gets arRequest
111 when (isNothing $ uriAuthority $ reqURI req) $
112 case reqVersion req of
113 -- HTTP/1.0 requests have no Host header so complete it
114 -- with the configuration value.
116 → let host = localHost
117 port = case localPort of
119 n → A.unsafeFromString $ ':':show n
120 req' = updateAuthority host port req
123 -- HTTP/1.1 requests MUST have a Host header, but if
124 -- the requested URI has an authority, the value of
125 -- Host header must be ignored. See:
126 -- http://tools.ietf.org/html/rfc2616#section-5.2
128 → case getHeader "Host" req of
130 | isNothing ∘ uriAuthority ∘ reqURI $ req
133 req' = updateAuthority host port req
139 → setStatus BadRequest
140 -- Should never reach here...
141 ver → fail ("internal error: unknown version: " ⧺ show ver)
143 parseHost ∷ Ascii → (CI Text, Ascii)
145 = let (h, p) = C8.break (≡ ':') $ cs hp
146 -- FIXME: should decode punycode here.
147 hText = CI.mk $ T.decodeUtf8 h
148 pAscii = A.unsafeFromByteString p
152 updateAuthority ∷ CI Text → Ascii → Request → Request
153 updateAuthority host port req@(Request {..})
154 = let uri' = reqURI {
155 uriAuthority = Just URIAuth {
157 , uriRegName = cs $ CI.original host
162 req { reqURI = uri' }
164 examineHeaders ∷ State AugmentedRequest ()
166 = do req ← gets arRequest
168 case getCIHeader "Expect" req of
172 → modify $ \ar → ar { arExpectedContinue = True }
174 → setStatus ExpectationFailed
176 case getCIHeader "Transfer-Encoding" req of
182 → setBodyLength $ Just Chunked
184 → setStatus NotImplemented
186 case cs <$> getHeader "Content-Length" req of
188 Just value → case C8.readInt value of
190 | C8.null garbage ∧ len ≥ 0
191 → setBodyLength $ Just $ Fixed len
192 _ → setStatus BadRequest
194 case getCIHeader "Connection" req of
200 examineBodyLength ∷ State AugmentedRequest ()
202 = do req ← gets arRequest
203 len ← gets arReqBodyLength
204 if reqHasBody req then
205 -- POST and PUT requests must have an entity body.
207 $ setStatus LengthRequired
209 -- Other requests must NOT have an entity body.
211 $ setStatus BadRequest