7 module Network.HTTP.Lucu.Preprocess
9 , RequestBodyLength(..)
13 import Control.Applicative
15 import Control.Monad.State
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
33 arRequest ∷ !(Maybe Request)
34 , arInitialStatus ∷ !StatusCode
36 , arWillDiscardBody ∷ !Bool
37 , arExpectedContinue ∷ !(Maybe Bool)
38 , arReqBodyLength ∷ !(Maybe RequestBodyLength)
41 data RequestBodyLength
47 → Either StatusCode Request
49 preprocess localHost localPort request
52 → preprocess' localHost localPort req
56 unparsable ∷ StatusCode → AugmentedRequest
60 , arInitialStatus = sc
62 , arWillDiscardBody = False
63 , arExpectedContinue = Nothing
64 , arReqBodyLength = Nothing
67 preprocess' ∷ Text → PortNumber → Request → AugmentedRequest
68 preprocess' localHost localPort req@(Request {..})
69 = execState go initialAR
71 initialAR ∷ AugmentedRequest
72 initialAR = AugmentedRequest {
74 , arInitialStatus = Ok
76 , arWillDiscardBody = False
77 , arExpectedContinue = Just False
78 , arReqBodyLength = Nothing
81 go ∷ State AugmentedRequest ()
82 go = do examineHttpVersion
84 examineAuthority localHost localPort
88 setRequest ∷ Request → State AugmentedRequest ()
90 = modify $ \ar → ar { arRequest = Just req }
92 setStatus ∷ StatusCode → State AugmentedRequest ()
94 = modify $ \ar → ar { arInitialStatus = sc }
96 setWillClose ∷ Bool → State AugmentedRequest ()
98 = modify $ \ar → ar { arWillClose = b }
100 setBodyLength ∷ Maybe RequestBodyLength → State AugmentedRequest ()
102 = modify $ \ar → ar { arReqBodyLength = len }
104 examineHttpVersion ∷ State AugmentedRequest ()
106 = do req ← gets (fromJust ∘ arRequest)
107 case reqVersion req of
108 -- HTTP/1.0 requests can't Keep-Alive.
113 _ → do setStatus HttpVersionNotSupported
116 examineMethod ∷ State AugmentedRequest ()
118 = do req ← gets (fromJust ∘ arRequest)
119 case reqMethod req of
121 HEAD → modify $ \ar → ar { arWillDiscardBody = True }
125 _ → setStatus NotImplemented
127 examineAuthority ∷ Text → PortNumber → State AugmentedRequest ()
128 examineAuthority localHost localPort
129 = do req ← gets (fromJust ∘ arRequest)
130 when (isNothing $ uriAuthority $ reqURI req) $
131 case reqVersion req of
132 -- HTTP/1.0 requests have no Host header so complete it
133 -- with the configuration value.
135 → let host = localHost
136 port = case localPort of
138 n → A.unsafeFromString $ ':':show n
139 req' = updateAuthority host port req
142 -- HTTP/1.1 requests MUST have a Host header.
144 → case getHeader "Host" req of
148 req' = updateAuthority host port req
152 → setStatus BadRequest
153 -- Should never reach here...
154 ver → fail ("internal error: unknown version: " ⧺ show ver)
156 parseHost ∷ Ascii → (Text, Ascii)
158 = let (h, p) = C8.break (≡ ':') $ A.toByteString hp
159 -- FIXME: should decode punycode here.
160 hText = T.decodeUtf8 h
161 pAscii = A.unsafeFromByteString p
165 updateAuthority ∷ Text → Ascii → Request → Request
166 updateAuthority host port req
167 = let uri = reqURI req
169 uriAuthority = Just URIAuth {
171 , uriRegName = T.unpack host
172 , uriPort = A.toString port
176 req { reqURI = uri' }
178 examineHeaders ∷ State AugmentedRequest ()
180 = do req ← gets (fromJust ∘ arRequest)
182 case getCIHeader "Expect" req of
186 → modify $ \ar → ar { arExpectedContinue = Just True }
188 → setStatus ExpectationFailed
190 case getCIHeader "Transfer-Encoding" req of
196 → setBodyLength $ Just Chunked
198 → setStatus NotImplemented
200 case A.toByteString <$> getHeader "Content-Length" req of
202 Just value → case C8.readInt value of
204 | C8.null garbage ∧ len ≥ 0
205 → setBodyLength $ Just $ Fixed len
206 _ → setStatus BadRequest
208 case getCIHeader "Connection" req of
214 examineBodyLength ∷ State AugmentedRequest ()
216 = do req ← gets (fromJust ∘ arRequest)
217 len ← gets arReqBodyLength
218 if reqHasBody req then
219 -- POST and PUT requests must have an entity body.
221 $ setStatus LengthRequired
223 -- Other requests must NOT have an entity body.
225 $ setStatus BadRequest