Network/HTTP/Lucu/Preprocess.hs

   1 -- #hide
   2 module Network.HTTP.Lucu.Preprocess
   3     ( preprocess
   4     )
   5     where
   6
   7 import           Control.Concurrent.STM
   8 import           Control.Monad
   9 import           Data.Char
  10 import           Data.Maybe
  11 import           Network.HTTP.Lucu.Headers
  12 import           Network.HTTP.Lucu.HttpVersion
  13 import           Network.HTTP.Lucu.Interaction
  14 import           Network.HTTP.Lucu.Request
  15 import           Network.HTTP.Lucu.Response
  16 import           Network.HTTP.Lucu.Utils
  17 import           Network.URI
  18
  19 {-
  20
  21   * Expect: に問題があった場合は 417 Expectation Failed に設定。
  22     100-continue 以外のものは全部 417 に。
  23
  24   * Transfer-Encoding: に問題があったら 501 Not Implemented にする。具
  25     体的には、identity でも chunked でもなければ 501 Not Implemented に
  26     する。
  27
  28   * HTTP/1.1 リクエストであり、URI にホスト名が無く、Host: ヘッダも無い
  29     場合には 400 Bad Request にする。
  30
  31   * メソッドが GET, HEAD, POST, PUT, DELETE の何れでもない場合は 501
  32     Not Implemented にする。
  33
  34   * HTTP/1.0 でも HTTP/1.1 でもないリクエストに對しては 505 HTTP
  35     Version Not Supported を返す。
  36
  37   * POST または PUT に Content-Length も Transfer-Encoding も無い時は、
  38     411 Length Required にする。
  39
  40   * Content-Length の値が數値でなかったり負だったりしたら 400 Bad
  41     Request にする。
  42
  43   * willDiscardBody その他の變數を設定する。
  44
  45 -}
  46
  47 import GHC.Conc (unsafeIOToSTM)
  48
  49 preprocess :: Interaction -> STM ()
  50 preprocess itr
  51     = do let req    = fromJust $ itrRequest itr
  52              reqVer = reqVersion req
  53
  54          if reqVer /= HttpVersion 1 0 &&
  55             reqVer /= HttpVersion 1 1 then
  56
  57              do setStatus itr HttpVersionNotSupported
  58                 writeItr itr itrWillClose True
  59
  60            else
  61              do if reqVer == HttpVersion 1 0 then
  62                     -- HTTP/1.0 では Keep-Alive できない
  63                     writeItr itr itrWillClose True
  64                   else
  65                     -- URI または Host: ヘッダのどちらかにホストが無ければ
  66                     -- ならない。
  67                     when (uriAuthority (reqURI req) == Nothing &&
  68                           getHeader "Host" req      == Nothing)
  69                              $ setStatus itr BadRequest
  70
  71                 case reqMethod req of
  72                   GET  -> return ()
  73                   HEAD -> writeItr itr itrWillDiscardBody True
  74                   POST -> writeItr itr itrRequestHasBody True
  75                   PUT  -> writeItr itr itrRequestHasBody True
  76                   _    -> setStatus itr NotImplemented
  77
  78                 mapM_ (preprocessHeader itr) (reqHeaders req)
  79     where
  80       setStatus itr status
  81           = updateItr itr itrResponse
  82             $ \ res -> res {
  83                          resStatus = status
  84                        }
  85
  86       preprocessHeader itr (name, value)
  87           = case map toLower name of
  88
  89               "expect"
  90                   -> if value `noCaseEq` "100-continue" then
  91                          writeItr itr itrExpectedContinue True
  92                      else
  93                          setStatus itr ExpectationFailed
  94
  95               "transfer-encoding"
  96                   -> case map toLower value of
  97                        "identity" -> return ()
  98                        "chunked"  -> writeItr itr itrRequestIsChunked True
  99                        _          -> setStatus itr NotImplemented
 100
 101               "content-length"
 102                   -> if all isDigit value then
 103                          do let len = read value
 104                             writeItr itr itrReqChunkLength    $ Just len
 105                             writeItr itr itrReqChunkRemaining $ Just len
 106                      else
 107                          setStatus itr BadRequest
 108
 109               "connection"
 110                   -> case map toLower value of
 111                        "close"      -> writeItr itr itrWillClose True
 112                        _            -> return ()
 113
 114               _ -> return ()