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.
 124                HttpVersion 1 1
 125                    → case getHeader "Host" req of
 126                         Just str
 127                             → let (host, port)
 128                                        = parseHost str
 129                                   req' = updateAuthority host port req
 130                               in
 131                                 setRequest req'
 132                         Nothing
 133                             → setStatus BadRequest
 134                -- Should never reach here...
 135                ver → fail ("internal error: unknown version: " ⧺ show ver)
 136
 137 parseHost ∷ Ascii → (CI Text, Ascii)
 138 parseHost hp
 139     = let (h, p) = C8.break (≡ ':') $ cs hp
 140           -- FIXME: should decode punycode here.
 141           hText  = CI.mk $ T.decodeUtf8 h
 142           pAscii = A.unsafeFromByteString p
 143       in
 144         (hText, pAscii)
 145
 146 updateAuthority ∷ CI Text → Ascii → Request → Request
 147 updateAuthority host port req
 148     = let uri  = reqURI req
 149           uri' = uri {
 150                    uriAuthority = Just URIAuth {
 151                                     uriUserInfo = ""
 152                                   , uriRegName  = cs $ CI.original host
 153                                   , uriPort     = cs port
 154                                   }
 155                  }
 156       in
 157         req { reqURI = uri' }
 158
 159 examineHeaders ∷ State AugmentedRequest ()
 160 examineHeaders
 161     = do req ← gets arRequest
 162
 163          case getCIHeader "Expect" req of
 164            Nothing → return ()
 165            Just v
 166                | v ≡ "100-continue"
 167                    → modify $ \ar → ar { arExpectedContinue = True }
 168                | otherwise
 169                    → setStatus ExpectationFailed
 170
 171          case getCIHeader "Transfer-Encoding" req of
 172            Nothing → return ()
 173            Just v
 174                | v ≡ "identity"
 175                    → return ()
 176                | v ≡ "chunked"
 177                    → setBodyLength $ Just Chunked
 178                | otherwise
 179                    → setStatus NotImplemented
 180
 181          case cs <$> getHeader "Content-Length" req of
 182            Nothing    → return ()
 183            Just value → case C8.readInt value of
 184                            Just (len, garbage)
 185                                | C8.null garbage ∧ len ≥ 0
 186                                    → setBodyLength $ Just $ Fixed len
 187                            _       → setStatus BadRequest
 188
 189          case getCIHeader "Connection" req of
 190            Just v
 191                | v ≡ "close"
 192                    → setWillClose True
 193            _       → return ()
 194
 195 examineBodyLength ∷ State AugmentedRequest ()
 196 examineBodyLength
 197     = do req ← gets arRequest
 198          len ← gets arReqBodyLength
 199          if reqHasBody req then
 200              -- POST and PUT requests must have an entity body.
 201              when (isNothing len)
 202                  $ setStatus LengthRequired
 203          else
 204              -- Other requests must NOT have an entity body.
 205              when (isJust len)
 206                  $ setStatus BadRequest