Network/HTTP/Lucu/Preprocess.hs

   1 {-# LANGUAGE
   2     DoAndIfThenElse
   3   , OverloadedStrings
   4   , RecordWildCards
   5   , UnicodeSyntax
   6   , ViewPatterns
   7   #-}
   8 module Network.HTTP.Lucu.Preprocess
   9     ( AugmentedRequest(..)
  10     , RequestBodyLength(..)
  11     , preprocess
  12     )
  13     where
  14 import Control.Applicative
  15 import Control.Applicative.Unicode
  16 import Control.Monad
  17 import Control.Monad.State.Strict
  18 import Data.Ascii (Ascii)
  19 import qualified Data.Ascii as A
  20 import qualified Data.ByteString.Char8 as C8
  21 import Data.CaseInsensitive (CI)
  22 import qualified Data.CaseInsensitive as CI
  23 import Data.Convertible.Base
  24 import Data.Convertible.Instances.Text ()
  25 import Data.Maybe
  26 import Data.Text (Text)
  27 import qualified Data.Text.Encoding as T
  28 import Network.HTTP.Lucu.Headers
  29 import Network.HTTP.Lucu.HttpVersion
  30 import Network.HTTP.Lucu.Request
  31 import Network.HTTP.Lucu.Response.StatusCode
  32 import Network.Socket
  33 import Network.URI
  34 import Prelude.Unicode
  35
  36 data AugmentedRequest
  37     = AugmentedRequest {
  38         arRequest          ∷ !Request
  39       , arInitialStatus    ∷ !SomeStatusCode
  40       , arWillChunkBody    ∷ !Bool
  41       , arWillClose        ∷ !Bool
  42       , arExpectedContinue ∷ !Bool
  43       , arReqBodyLength    ∷ !(Maybe RequestBodyLength)
  44       }
  45
  46 data RequestBodyLength
  47     = Fixed !Int
  48     | Chunked
  49     deriving (Eq, Show)
  50
  51 preprocess ∷ CI Text → PortNumber → Bool → Request → AugmentedRequest
  52 preprocess localHost localPort isSSL req@(Request {..})
  53     = execState go initialAR
  54     where
  55       initialAR ∷ AugmentedRequest
  56       initialAR = AugmentedRequest {
  57                     arRequest          = req
  58                   , arInitialStatus    = fromStatusCode OK
  59                   , arWillChunkBody    = False
  60                   , arWillClose        = False
  61                   , arExpectedContinue = False
  62                   , arReqBodyLength    = Nothing
  63                   }
  64       go ∷ State AugmentedRequest ()
  65       go = do examineHttpVersion
  66               examineMethod
  67               examineScheme isSSL
  68               examineAuthority localHost localPort
  69               examineHeaders
  70               examineBodyLength
  71
  72 setRequest ∷ Request → State AugmentedRequest ()
  73 setRequest req
  74     = modify $ \ar → ar { arRequest = req }
  75
  76 setStatus ∷ StatusCode sc ⇒ sc → State AugmentedRequest ()
  77 setStatus sc
  78     = modify $ \ar → ar { arInitialStatus = fromStatusCode sc }
  79
  80 setWillClose ∷ Bool → State AugmentedRequest ()
  81 setWillClose b
  82     = modify $ \ar → ar { arWillClose = b }
  83
  84 setBodyLength ∷ Maybe RequestBodyLength → State AugmentedRequest ()
  85 setBodyLength len
  86     = modify $ \ar → ar { arReqBodyLength = len }
  87
  88 examineHttpVersion ∷ State AugmentedRequest ()
  89 examineHttpVersion
  90     = do req ← gets arRequest
  91          case reqVersion req of
  92            -- HTTP/1.0 requests can't Keep-Alive.
  93            HttpVersion 1 0
  94                → setWillClose True
  95            HttpVersion 1 1
  96                → modify $ \ar → ar { arWillChunkBody = True }
  97            _   → do setStatus    HTTPVersionNotSupported
  98                     setWillClose True
  99
 100 examineMethod ∷ State AugmentedRequest ()
 101 examineMethod
 102     = do req ← gets arRequest
 103          case reqMethod req of
 104            GET    → return ()
 105            HEAD   → return ()
 106            POST   → return ()
 107            PUT    → return ()
 108            DELETE → return ()
 109            _      → setStatus NotImplemented
 110
 111 examineScheme ∷ Bool → State AugmentedRequest ()
 112 examineScheme isSSL
 113     = do req ← gets arRequest
 114          when (null ∘ uriScheme $ reqURI req) $
 115              let uri' = (reqURI req) {
 116                           uriScheme = if isSSL then
 117                                           "https:"
 118                                       else
 119                                           "http:"
 120                         }
 121                  req' = req { reqURI = uri' }
 122              in
 123                setRequest req'
 124
 125 examineAuthority ∷ CI Text → PortNumber → State AugmentedRequest ()
 126 examineAuthority localHost localPort
 127     = do req ← gets arRequest
 128          when (isNothing $ uriAuthority $ reqURI req) $
 129              case reqVersion req of
 130                -- HTTP/1.0 requests have no Host header so complete it
 131                -- with the configuration value.
 132                HttpVersion 1 0
 133                    → let host = localHost
 134                          port = case localPort of
 135                                   n | Just n ≡ defaultPort (reqURI req)
 136                                         → ""
 137                                   n     → A.unsafeFromString $ ':':show n
 138                          req' = updateAuthority host port req
 139                      in
 140                        setRequest req'
 141                -- HTTP/1.1 requests MUST have a Host header, but if
 142                -- the requested URI has an authority, the value of
 143                -- Host header must be ignored. See:
 144                -- http://tools.ietf.org/html/rfc2616#section-5.2
 145                HttpVersion 1 1
 146                    → case getHeader "Host" req of
 147                         Just str
 148                             | isNothing ∘ uriAuthority ∘ reqURI $ req
 149                                 → let (host, port)
 150                                            = parseHost str
 151                                       req' = updateAuthority host port req
 152                                   in
 153                                     setRequest req'
 154                             | otherwise
 155                                 → return ()
 156                         Nothing
 157                             → setStatus BadRequest
 158                -- Should never reach here...
 159                ver → fail ("internal error: unknown version: " ⧺ show ver)
 160
 161 defaultPort ∷ Alternative f ⇒ URI → f PortNumber
 162 {-# INLINEABLE defaultPort #-}
 163 defaultPort (uriScheme → s)
 164     | s ≡ "http:"  = pure 80
 165     | s ≡ "https:" = pure 443
 166     | otherwise    = (∅)
 167
 168 parseHost ∷ Ascii → (CI Text, Ascii)
 169 parseHost hp
 170     = let (h, p) = C8.break (≡ ':') $ cs hp
 171           -- FIXME: should decode punycode here.
 172           hText  = CI.mk $ T.decodeUtf8 h
 173           pAscii = A.unsafeFromByteString p
 174       in
 175         (hText, pAscii)
 176
 177 updateAuthority ∷ CI Text → Ascii → Request → Request
 178 updateAuthority host port req@(Request {..})
 179     = let uri' = reqURI {
 180                    uriAuthority = Just URIAuth {
 181                                     uriUserInfo = ""
 182                                   , uriRegName  = cs $ CI.original host
 183                                   , uriPort     = cs port
 184                                   }
 185                  }
 186       in
 187         req { reqURI = uri' }
 188
 189 examineHeaders ∷ State AugmentedRequest ()
 190 examineHeaders
 191     = do req ← gets arRequest
 192
 193          case getCIHeader "Expect" req of
 194            Nothing → return ()
 195            Just v
 196                | v ≡ "100-continue"
 197                    → modify $ \ar → ar { arExpectedContinue = True }
 198                | otherwise
 199                    → setStatus ExpectationFailed
 200
 201          case getCIHeader "Transfer-Encoding" req of
 202            Nothing → return ()
 203            Just v
 204                | v ≡ "identity"
 205                    → return ()
 206                | v ≡ "chunked"
 207                    → setBodyLength $ Just Chunked
 208                | otherwise
 209                    → setStatus NotImplemented
 210
 211          case cs <$> getHeader "Content-Length" req of
 212            Nothing    → return ()
 213            Just value → case C8.readInt value of
 214                            Just (len, garbage)
 215                                | C8.null garbage ∧ len ≥ 0
 216                                    → setBodyLength $ Just $ Fixed len
 217                            _       → setStatus BadRequest
 218
 219          case getCIHeader "Connection" req of
 220            Just v
 221                | v ≡ "close"
 222                    → setWillClose True
 223            _       → return ()
 224
 225 examineBodyLength ∷ State AugmentedRequest ()
 226 examineBodyLength
 227     = do req ← gets arRequest
 228          len ← gets arReqBodyLength
 229          if reqHasBody req then
 230              -- POST and PUT requests must have an entity body.
 231              when (isNothing len)
 232                  $ setStatus LengthRequired
 233          else
 234              -- Other requests must NOT have an entity body.
 235              when (isJust len)
 236                  $ setStatus BadRequest