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