, OverloadedStrings
, RecordWildCards
, UnicodeSyntax
+ , ViewPatterns
#-}
module Network.HTTP.Lucu.Preprocess
( AugmentedRequest(..)
)
where
import Control.Applicative
+import Control.Applicative.Unicode
import Control.Monad
import Control.Monad.State.Strict
import Data.Ascii (Ascii)
import qualified Data.ByteString.Char8 as C8
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
+import Data.Convertible.Base
+import Data.Convertible.Instances.Text ()
import Data.Maybe
import Data.Text (Text)
-import qualified Data.Text as T
import qualified Data.Text.Encoding as T
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)
| Chunked
deriving (Eq, Show)
-preprocess ∷ CI Text → PortNumber → Request → AugmentedRequest
-preprocess localHost localPort req@(Request {..})
+preprocess ∷ CI Text → PortNumber → Bool → Request → AugmentedRequest
+preprocess localHost localPort isSSL req@(Request {..})
= execState go initialAR
where
initialAR ∷ AugmentedRequest
arRequest = req
, arInitialStatus = fromStatusCode OK
, arWillChunkBody = False
- , arWillDiscardBody = False
, arWillClose = False
, arExpectedContinue = False
, arReqBodyLength = Nothing
go ∷ State AugmentedRequest ()
go = do examineHttpVersion
examineMethod
+ examineScheme isSSL
examineAuthority localHost localPort
examineHeaders
examineBodyLength
= do req ← gets arRequest
case reqMethod req of
GET → return ()
- HEAD → modify $ \ar → ar { arWillDiscardBody = True }
+ HEAD → return ()
POST → return ()
PUT → return ()
DELETE → return ()
_ → setStatus NotImplemented
+examineScheme ∷ Bool → State AugmentedRequest ()
+examineScheme isSSL
+ = do req ← gets arRequest
+ when (null ∘ uriScheme $ reqURI req) $
+ let uri' = (reqURI req) {
+ uriScheme = if isSSL then
+ "https:"
+ else
+ "http:"
+ }
+ req' = req { reqURI = uri' }
+ in
+ setRequest req'
+
examineAuthority ∷ CI Text → PortNumber → State AugmentedRequest ()
examineAuthority localHost localPort
= do req ← gets arRequest
HttpVersion 1 0
→ let host = localHost
port = case localPort of
- 80 → ""
- n → A.unsafeFromString $ ':':show n
+ n | Just n ≡ defaultPort (reqURI req)
+ → ""
+ n → A.unsafeFromString $ ':':show n
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...
ver → fail ("internal error: unknown version: " ⧺ show ver)
+defaultPort ∷ Alternative f ⇒ URI → f PortNumber
+{-# INLINEABLE defaultPort #-}
+defaultPort (uriScheme → s)
+ | s ≡ "http:" = pure 80
+ | s ≡ "https:" = pure 443
+ | otherwise = (∅)
+
parseHost ∷ Ascii → (CI Text, Ascii)
parseHost hp
- = let (h, p) = C8.break (≡ ':') $ A.toByteString hp
+ = let (h, p) = C8.break (≡ ':') $ cs hp
-- FIXME: should decode punycode here.
hText = CI.mk $ T.decodeUtf8 h
pAscii = A.unsafeFromByteString p
(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 = T.unpack $ CI.original host
- , uriPort = A.toString port
+ , uriRegName = cs $ CI.original host
+ , uriPort = cs port
}
}
in
| otherwise
→ setStatus NotImplemented
- case A.toByteString <$> getHeader "Content-Length" req of
+ case cs <$> getHeader "Content-Length" req of
Nothing → return ()
Just value → case C8.readInt value of
Just (len, garbage)
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