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