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.Convertible.Instances.Text ()
  23 import Data.Maybe
  24 import Data.Text (Text)
  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  = cs $ 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