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