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 qualified Data.Strict.Maybe as S
  21 import Data.Text (Text)
  22 import qualified Data.Text as T
  23 import qualified Data.Text.Encoding as T
  24 import Network.HTTP.Lucu.Headers
  25 import Network.HTTP.Lucu.HttpVersion
  26 import Network.HTTP.Lucu.Request
  27 import Network.HTTP.Lucu.Response
  28 import Network.Socket
  29 import Network.URI
  30 import Prelude.Unicode
  31
  32 data AugmentedRequest
  33     = AugmentedRequest {
  34         arRequest          ∷ !Request
  35       , arInitialStatus    ∷ !StatusCode
  36       , arWillChunkBody    ∷ !Bool
  37       , arWillDiscardBody  ∷ !Bool
  38       , arWillClose        ∷ !Bool
  39       , arExpectedContinue ∷ !Bool
  40       , arReqBodyLength    ∷ !(S.Maybe RequestBodyLength)
  41       }
  42
  43 data RequestBodyLength
  44     = Fixed !Int
  45     | Chunked
  46     deriving (Eq, Show)
  47
  48 preprocess ∷ Text → PortNumber → Request → AugmentedRequest
  49 preprocess localHost localPort req@(Request {..})
  50     = execState go initialAR
  51     where
  52       initialAR ∷ AugmentedRequest
  53       initialAR = AugmentedRequest {
  54                     arRequest          = req
  55                   , arInitialStatus    = Ok
  56                   , arWillChunkBody    = False
  57                   , arWillDiscardBody  = False
  58                   , arWillClose        = False
  59                   , arExpectedContinue = False
  60                   , arReqBodyLength    = S.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 → State AugmentedRequest ()
  74 setStatus sc
  75     = modify $ \ar → ar { arInitialStatus = sc }
  76
  77 setWillClose ∷ Bool → State AugmentedRequest ()
  78 setWillClose b
  79     = modify $ \ar → ar { arWillClose = b }
  80
  81 setBodyLength ∷ S.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   → modify $ \ar → ar { arWillDiscardBody = True }
 103            POST   → return ()
 104            PUT    → return ()
 105            DELETE → return ()
 106            _      → setStatus NotImplemented
 107
 108 examineAuthority ∷ 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 → (Text, Ascii)
 138 parseHost hp
 139     = let (h, p) = C8.break (≡ ':') $ A.toByteString hp
 140           -- FIXME: should decode punycode here.
 141           hText  = T.decodeUtf8 h
 142           pAscii = A.unsafeFromByteString p
 143       in
 144         (hText, pAscii)
 145
 146 updateAuthority ∷ 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  = T.unpack host
 153                                   , uriPort     = A.toString 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 $ S.Just Chunked
 178                | otherwise
 179                    → setStatus NotImplemented
 180
 181          case A.toByteString <$> 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 $ S.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 reqMustHaveBody req then
 200              -- POST and PUT requests must have an entity body.
 201              when (S.isNothing len)
 202                  $ setStatus LengthRequired
 203          else
 204              -- Other requests must NOT have an entity body.
 205              when (S.isJust len)
 206                  $ setStatus BadRequest