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