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
23 import Data.Text (Text)
24 import qualified Data.Text as T
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
39 , arWillDiscardBody ∷ !Bool
41 , arExpectedContinue ∷ !Bool
42 , arReqBodyLength ∷ !(Maybe RequestBodyLength)
45 data RequestBodyLength
50 preprocess ∷ CI Text → PortNumber → Request → AugmentedRequest
51 preprocess localHost localPort req@(Request {..})
52 = execState go initialAR
54 initialAR ∷ AugmentedRequest
55 initialAR = AugmentedRequest {
57 , arInitialStatus = fromStatusCode OK
58 , arWillChunkBody = False
59 , arWillDiscardBody = False
61 , arExpectedContinue = False
62 , arReqBodyLength = Nothing
64 go ∷ State AugmentedRequest ()
65 go = do examineHttpVersion
67 examineAuthority localHost localPort
71 setRequest ∷ Request → State AugmentedRequest ()
73 = modify $ \ar → ar { arRequest = req }
75 setStatus ∷ StatusCode sc ⇒ sc → State AugmentedRequest ()
77 = modify $ \ar → ar { arInitialStatus = fromStatusCode sc }
79 setWillClose ∷ Bool → State AugmentedRequest ()
81 = modify $ \ar → ar { arWillClose = b }
83 setBodyLength ∷ Maybe RequestBodyLength → State AugmentedRequest ()
85 = modify $ \ar → ar { arReqBodyLength = len }
87 examineHttpVersion ∷ State AugmentedRequest ()
89 = do req ← gets arRequest
90 case reqVersion req of
91 -- HTTP/1.0 requests can't Keep-Alive.
95 → modify $ \ar → ar { arWillChunkBody = True }
96 _ → do setStatus HTTPVersionNotSupported
99 examineMethod ∷ State AugmentedRequest ()
101 = do req ← gets arRequest
102 case reqMethod req of
104 HEAD → modify $ \ar → ar { arWillDiscardBody = True }
108 _ → setStatus NotImplemented
110 examineAuthority ∷ CI Text → PortNumber → State AugmentedRequest ()
111 examineAuthority localHost localPort
112 = do req ← gets arRequest
113 when (isNothing $ uriAuthority $ reqURI req) $
114 case reqVersion req of
115 -- HTTP/1.0 requests have no Host header so complete it
116 -- with the configuration value.
118 → let host = localHost
119 port = case localPort of
121 n → A.unsafeFromString $ ':':show n
122 req' = updateAuthority host port req
125 -- HTTP/1.1 requests MUST have a Host header.
127 → case getHeader "Host" req of
131 req' = updateAuthority host port req
135 → setStatus BadRequest
136 -- Should never reach here...
137 ver → fail ("internal error: unknown version: " ⧺ show ver)
139 parseHost ∷ Ascii → (CI Text, Ascii)
141 = let (h, p) = C8.break (≡ ':') $ cs hp
142 -- FIXME: should decode punycode here.
143 hText = CI.mk $ T.decodeUtf8 h
144 pAscii = A.unsafeFromByteString p
148 updateAuthority ∷ CI Text → Ascii → Request → Request
149 updateAuthority host port req
150 = let uri = reqURI req
152 uriAuthority = Just URIAuth {
154 , uriRegName = T.unpack $ CI.original host
159 req { reqURI = uri' }
161 examineHeaders ∷ State AugmentedRequest ()
163 = do req ← gets arRequest
165 case getCIHeader "Expect" req of
169 → modify $ \ar → ar { arExpectedContinue = True }
171 → setStatus ExpectationFailed
173 case getCIHeader "Transfer-Encoding" req of
179 → setBodyLength $ Just Chunked
181 → setStatus NotImplemented
183 case cs <$> getHeader "Content-Length" req of
185 Just value → case C8.readInt value of
187 | C8.null garbage ∧ len ≥ 0
188 → setBodyLength $ Just $ Fixed len
189 _ → setStatus BadRequest
191 case getCIHeader "Connection" req of
197 examineBodyLength ∷ State AugmentedRequest ()
199 = do req ← gets arRequest
200 len ← gets arReqBodyLength
201 if reqMustHaveBody req then
202 -- POST and PUT requests must have an entity body.
204 $ setStatus LengthRequired
206 -- Other requests must NOT have an entity body.
208 $ setStatus BadRequest