Network/HTTP/Lucu/Preprocess.hs

   1 {-# LANGUAGE
   2     BangPatterns
   3   #-}
   4 module Network.HTTP.Lucu.Preprocess
   5     ( preprocess
   6     )
   7     where
   8
   9 import           Control.Concurrent.STM
  10 import           Control.Monad
  11 import qualified Data.ByteString as Strict (ByteString)
  12 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
  13 import           Data.Char
  14 import           Data.Maybe
  15 import           Network.HTTP.Lucu.Config
  16 import           Network.HTTP.Lucu.Headers
  17 import           Network.HTTP.Lucu.HttpVersion
  18 import           Network.HTTP.Lucu.Interaction
  19 import           Network.HTTP.Lucu.Request
  20 import           Network.HTTP.Lucu.Response
  21 import           Network.URI
  22
  23 {-
  24
  25   * URI にホスト名が存在しない時、
  26     [1] HTTP/1.0 ならば Config を使って補完
  27     [2] HTTP/1.1 ならば Host ヘッダで補完。Host が無ければ 400。
  28
  29   * Expect: に問題があった場合は 417 Expectation Failed に設定。
  30     100-continue 以外のものは全部 417 に。
  31
  32   * Transfer-Encoding: に問題があったら 501 Not Implemented にする。具
  33     体的には、identity でも chunked でもなければ 501 Not Implemented に
  34     する。
  35
  36   * メソッドが GET, HEAD, POST, PUT, DELETE の何れでもない場合は 501
  37     Not Implemented にする。
  38
  39   * HTTP/1.0 でも HTTP/1.1 でもないリクエストに對しては 505 HTTP
  40     Version Not Supported を返す。
  41
  42   * POST または PUT に Content-Length も Transfer-Encoding も無い時は、
  43     411 Length Required にする。
  44
  45   * Content-Length の値が數値でなかったり負だったりしたら 400 Bad
  46     Request にする。
  47
  48   * willDiscardBody その他の變數を設定する。
  49
  50 -}
  51
  52 preprocess :: Interaction -> STM ()
  53 preprocess !itr
  54     = do req <- readItr itr itrRequest fromJust
  55
  56          let reqVer = reqVersion req
  57
  58          if reqVer /= HttpVersion 1 0 &&
  59             reqVer /= HttpVersion 1 1 then
  60
  61              do setStatus HttpVersionNotSupported
  62                 writeItr itr itrWillClose True
  63
  64            else
  65              -- HTTP/1.0 では Keep-Alive できない
  66              do when (reqVer == HttpVersion 1 0)
  67                      $ writeItr itr itrWillClose True
  68
  69                 -- ホスト部の補完
  70                 completeAuthority req
  71
  72                 case reqMethod req of
  73                   GET    -> return ()
  74                   HEAD   -> writeItr itr itrWillDiscardBody True
  75                   POST   -> writeItr itr itrRequestHasBody True
  76                   PUT    -> writeItr itr itrRequestHasBody True
  77                   DELETE -> return ()
  78                   _      -> setStatus NotImplemented
  79
  80                 preprocessHeader req
  81     where
  82       setStatus :: StatusCode -> STM ()
  83       setStatus !status
  84           = updateItr itr itrResponse
  85             $! \ res -> res {
  86                           resStatus = status
  87                         }
  88
  89       completeAuthority :: Request -> STM ()
  90       completeAuthority !req
  91           = when (uriAuthority (reqURI req) == Nothing)
  92             $ if reqVersion req == HttpVersion 1 0 then
  93                   -- HTTP/1.0 なので Config から補完
  94                   do let conf = itrConfig itr
  95                          host = cnfServerHost conf
  96                          port = itrLocalPort itr
  97                          portStr
  98                               = case port of
  99                                   80 -> ""
 100                                   n  -> ':' : show n
 101                      updateAuthority host (C8.pack portStr)
 102               else
 103                   case getHeader (C8.pack "Host") req of
 104                     Just str -> let (host, portStr) = parseHost str
 105                                 in updateAuthority host portStr
 106                     Nothing  -> setStatus BadRequest
 107
 108
 109       parseHost :: Strict.ByteString -> (Strict.ByteString, Strict.ByteString)
 110       parseHost = C8.break (== ':')
 111
 112
 113       updateAuthority :: Strict.ByteString -> Strict.ByteString -> STM ()
 114       updateAuthority !host !portStr
 115           = updateItr itr itrRequest
 116             $! \ (Just req) -> Just req {
 117                                  reqURI = let uri = reqURI req
 118                                           in uri {
 119                                                uriAuthority = Just URIAuth {
 120                                                                    uriUserInfo = ""
 121                                                                  , uriRegName  = C8.unpack host
 122                                                                  , uriPort     = C8.unpack portStr
 123                                                               }
 124                                              }
 125                                }
 126
 127
 128       preprocessHeader :: Request -> STM ()
 129       preprocessHeader !req
 130           = do case getHeader (C8.pack "Expect") req of
 131                  Nothing    -> return ()
 132                  Just value -> if value `noCaseEq` C8.pack "100-continue" then
 133                                    writeItr itr itrExpectedContinue True
 134                                else
 135                                    setStatus ExpectationFailed
 136
 137                case getHeader (C8.pack "Transfer-Encoding") req of
 138                  Nothing    -> return ()
 139                  Just value -> unless (value `noCaseEq` C8.pack "identity")
 140                                    $ if value `noCaseEq` C8.pack "chunked" then
 141                                          writeItr itr itrRequestIsChunked True
 142                                      else
 143                                          setStatus NotImplemented
 144
 145                case getHeader (C8.pack "Content-Length") req of
 146                  Nothing    -> return ()
 147                  Just value -> if C8.all isDigit value then
 148                                    do let Just (len, _) = C8.readInt value
 149                                       writeItr itr itrReqChunkLength    $ Just len
 150                                       writeItr itr itrReqChunkRemaining $ Just len
 151                                else
 152                                    setStatus BadRequest
 153
 154                case getHeader (C8.pack "Connection") req of
 155                  Nothing    -> return ()
 156                  Just value -> when (value `noCaseEq` C8.pack "close")
 157                                    $ writeItr itr itrWillClose True