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
20 import Data.Text (Text)
21 import qualified Data.Text as T
22 import qualified Data.Text.Encoding as T
23 import Network.HTTP.Lucu.Headers
24 import Network.HTTP.Lucu.HttpVersion
25 import Network.HTTP.Lucu.Request
26 import Network.HTTP.Lucu.Response
29 import Prelude.Unicode
34 , arInitialStatus ∷ !StatusCode
35 , arWillChunkBody ∷ !Bool
36 , arWillDiscardBody ∷ !Bool
38 , arExpectedContinue ∷ !Bool
39 , arReqBodyLength ∷ !(Maybe RequestBodyLength)
42 data RequestBodyLength
47 preprocess ∷ Text → PortNumber → Request → AugmentedRequest
48 preprocess localHost localPort req@(Request {..})
49 = execState go initialAR
51 initialAR ∷ AugmentedRequest
52 initialAR = AugmentedRequest {
54 , arInitialStatus = Ok
55 , arWillChunkBody = False
56 , arWillDiscardBody = False
58 , arExpectedContinue = False
59 , arReqBodyLength = Nothing
61 go ∷ State AugmentedRequest ()
62 go = do examineHttpVersion
64 examineAuthority localHost localPort
68 setRequest ∷ Request → State AugmentedRequest ()
70 = modify $ \ar → ar { arRequest = req }
72 setStatus ∷ StatusCode → State AugmentedRequest ()
74 = modify $ \ar → ar { arInitialStatus = sc }
76 setWillClose ∷ Bool → State AugmentedRequest ()
78 = modify $ \ar → ar { arWillClose = b }
80 setBodyLength ∷ Maybe RequestBodyLength → State AugmentedRequest ()
82 = modify $ \ar → ar { arReqBodyLength = len }
84 examineHttpVersion ∷ State AugmentedRequest ()
86 = do req ← gets arRequest
87 case reqVersion req of
88 -- HTTP/1.0 requests can't Keep-Alive.
92 → modify $ \ar → ar { arWillChunkBody = True }
93 _ → do setStatus HttpVersionNotSupported
96 examineMethod ∷ State AugmentedRequest ()
98 = do req ← gets arRequest
101 HEAD → modify $ \ar → ar { arWillDiscardBody = True }
105 _ → setStatus NotImplemented
107 examineAuthority ∷ Text → PortNumber → State AugmentedRequest ()
108 examineAuthority localHost localPort
109 = do req ← gets arRequest
110 when (isNothing $ uriAuthority $ reqURI req) $
111 case reqVersion req of
112 -- HTTP/1.0 requests have no Host header so complete it
113 -- with the configuration value.
115 → let host = localHost
116 port = case localPort of
118 n → A.unsafeFromString $ ':':show n
119 req' = updateAuthority host port req
122 -- HTTP/1.1 requests MUST have a Host header.
124 → case getHeader "Host" req of
128 req' = updateAuthority host port req
132 → setStatus BadRequest
133 -- Should never reach here...
134 ver → fail ("internal error: unknown version: " ⧺ show ver)
136 parseHost ∷ Ascii → (Text, Ascii)
138 = let (h, p) = C8.break (≡ ':') $ A.toByteString hp
139 -- FIXME: should decode punycode here.
140 hText = T.decodeUtf8 h
141 pAscii = A.unsafeFromByteString p
145 updateAuthority ∷ Text → Ascii → Request → Request
146 updateAuthority host port req
147 = let uri = reqURI req
149 uriAuthority = Just URIAuth {
151 , uriRegName = T.unpack host
152 , uriPort = A.toString port
156 req { reqURI = uri' }
158 examineHeaders ∷ State AugmentedRequest ()
160 = do req ← gets arRequest
162 case getCIHeader "Expect" req of
166 → modify $ \ar → ar { arExpectedContinue = True }
168 → setStatus ExpectationFailed
170 case getCIHeader "Transfer-Encoding" req of
176 → setBodyLength $ Just Chunked
178 → setStatus NotImplemented
180 case A.toByteString <$> getHeader "Content-Length" req of
182 Just value → case C8.readInt value of
184 | C8.null garbage ∧ len ≥ 0
185 → setBodyLength $ Just $ Fixed len
186 _ → setStatus BadRequest
188 case getCIHeader "Connection" req of
194 examineBodyLength ∷ State AugmentedRequest ()
196 = do req ← gets arRequest
197 len ← gets arReqBodyLength
198 if reqMustHaveBody req then
199 -- POST and PUT requests must have an entity body.
201 $ setStatus LengthRequired
203 -- Other requests must NOT have an entity body.
205 $ setStatus BadRequest