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