Network/HTTP/Lucu/Preprocess.hs

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