import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Request
-import Network.HTTP.Lucu.Response
+import Network.HTTP.Lucu.Response.StatusCode
import Network.Socket
import Network.URI
import Prelude.Unicode
arRequest ∷ !Request
, arInitialStatus ∷ !SomeStatusCode
, arWillChunkBody ∷ !Bool
- , arWillDiscardBody ∷ !Bool
, arWillClose ∷ !Bool
, arExpectedContinue ∷ !Bool
, arReqBodyLength ∷ !(Maybe RequestBodyLength)
arRequest = req
, arInitialStatus = fromStatusCode OK
, arWillChunkBody = False
- , arWillDiscardBody = False
, arWillClose = False
, arExpectedContinue = False
, arReqBodyLength = Nothing
= do req ← gets arRequest
case reqMethod req of
GET → return ()
- HEAD → modify $ \ar → ar { arWillDiscardBody = True }
+ HEAD → return ()
POST → return ()
PUT → return ()
DELETE → return ()
req' = updateAuthority host port req
in
setRequest req'
- -- HTTP/1.1 requests MUST have a Host header.
+ -- HTTP/1.1 requests MUST have a Host header, but if
+ -- the requested URI has an authority, the value of
+ -- Host header must be ignored. See:
+ -- http://tools.ietf.org/html/rfc2616#section-5.2
HttpVersion 1 1
→ case getHeader "Host" req of
Just str
- → let (host, port)
- = parseHost str
- req' = updateAuthority host port req
- in
- setRequest req'
+ | isNothing ∘ uriAuthority ∘ reqURI $ req
+ → let (host, port)
+ = parseHost str
+ req' = updateAuthority host port req
+ in
+ setRequest req'
+ | otherwise
+ → return ()
Nothing
→ setStatus BadRequest
-- Should never reach here...
(hText, pAscii)
updateAuthority ∷ CI Text → Ascii → Request → Request
-updateAuthority host port req
- = let uri = reqURI req
- uri' = uri {
+updateAuthority host port req@(Request {..})
+ = let uri' = reqURI {
uriAuthority = Just URIAuth {
uriUserInfo = ""
, uriRegName = cs $ CI.original host
examineBodyLength
= do req ← gets arRequest
len ← gets arReqBodyLength
- if reqMustHaveBody req then
+ if reqHasBody req then
-- POST and PUT requests must have an entity body.
when (isNothing len)
$ setStatus LengthRequired