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
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.
125 → case getHeader "Host" req of
129 req' = updateAuthority host port req
133 → setStatus BadRequest
134 -- Should never reach here...
135 ver → fail ("internal error: unknown version: " ⧺ show ver)
137 parseHost ∷ Ascii → (CI Text, Ascii)
139 = let (h, p) = C8.break (≡ ':') $ cs hp
140 -- FIXME: should decode punycode here.
141 hText = CI.mk $ T.decodeUtf8 h
142 pAscii = A.unsafeFromByteString p
146 updateAuthority ∷ CI Text → Ascii → Request → Request
147 updateAuthority host port req
148 = let uri = reqURI req
150 uriAuthority = Just URIAuth {
152 , uriRegName = cs $ CI.original host
157 req { reqURI = uri' }
159 examineHeaders ∷ State AugmentedRequest ()
161 = do req ← gets arRequest
163 case getCIHeader "Expect" req of
167 → modify $ \ar → ar { arExpectedContinue = True }
169 → setStatus ExpectationFailed
171 case getCIHeader "Transfer-Encoding" req of
177 → setBodyLength $ Just Chunked
179 → setStatus NotImplemented
181 case cs <$> getHeader "Content-Length" req of
183 Just value → case C8.readInt value of
185 | C8.null garbage ∧ len ≥ 0
186 → setBodyLength $ Just $ Fixed len
187 _ → setStatus BadRequest
189 case getCIHeader "Connection" req of
195 examineBodyLength ∷ State AugmentedRequest ()
197 = do req ← gets arRequest
198 len ← gets arReqBodyLength
199 if reqMustHaveBody req then
200 -- POST and PUT requests must have an entity body.
202 $ setStatus LengthRequired
204 -- Other requests must NOT have an entity body.
206 $ setStatus BadRequest