Network/HTTP/Lucu/Preprocess.hs

   1 module Network.HTTP.Lucu.Preprocess
   2     ( preprocess -- Interaction -> STM ()
   3     )
   4     where
   5
   6 import           Control.Concurrent.STM
   7 import           Control.Monad
   8 import           Data.Char
   9 import           Data.Maybe
  10 import           Network.HTTP.Lucu.Headers
  11 import           Network.HTTP.Lucu.HttpVersion
  12 import           Network.HTTP.Lucu.Interaction
  13 import           Network.HTTP.Lucu.Request
  14 import           Network.HTTP.Lucu.Response
  15 import           Network.HTTP.Lucu.Utils
  16 import           Network.URI
  17
  18 {-
  19
  20   * Expect: に問題があった場合は 417 Expectation Failed に設定。
  21     100-continue 以外のものは全部 417 に。
  22
  23   * Transfer-Encoding: に問題があったら 501 Not Implemented にする。具
  24     体的には、identity でも chunked でもなければ 501 Not Implemented に
  25     する。
  26
  27   * HTTP/1.1 リクエストであり、URI にホスト名が無く、Host: ヘッダも無い
  28     場合には 400 Bad Request にする。
  29
  30   * メソッドが GET, HEAD, POST, PUT, DELETE の何れでもない場合は 501
  31     Not Implemented にする。
  32
  33   * HTTP/1.0 でも HTTP/1.1 でもないリクエストに對しては 505 HTTP
  34     Version Not Supported を返す。
  35
  36   * POST または PUT に Content-Length も Transfer-Encoding も無い時は、
  37     411 Length Required にする。
  38
  39   * Content-Length の値が數値でなかったり負だったりしたら 400 Bad
  40     Request にする。
  41
  42   * willDiscardBody その他の變數を設定する。
  43
  44 -}
  45
  46 import GHC.Conc (unsafeIOToSTM)
  47
  48 preprocess :: Interaction -> STM ()
  49 preprocess itr
  50     = do let req    = fromJust $ itrRequest itr
  51              reqVer = reqVersion req
  52
  53          if reqVer /= HttpVersion 1 0 &&
  54             reqVer /= HttpVersion 1 1 then
  55
  56              do setStatus itr HttpVersionNotSupported
  57                 writeItr itr itrWillClose True
  58
  59            else
  60              do if reqVer == HttpVersion 1 0 then
  61                     -- HTTP/1.0 では Keep-Alive できない
  62                     writeItr itr itrWillClose True
  63                   else
  64                     -- URI または Host: ヘッダのどちらかにホストが無ければ
  65                     -- ならない。
  66                     when (uriAuthority (reqURI req) == Nothing &&
  67                           getHeader "Host" req      == Nothing)
  68                              $ setStatus itr BadRequest
  69
  70                 case reqMethod req of
  71                   GET  -> return ()
  72                   HEAD -> writeItr itr itrWillDiscardBody True
  73                   POST -> writeItr itr itrRequestHasBody True
  74                   PUT  -> writeItr itr itrRequestHasBody True
  75                   _    -> setStatus itr NotImplemented
  76
  77                 mapM_ (preprocessHeader itr) (reqHeaders req)
  78     where
  79       setStatus itr status
  80           = writeItr itr itrResponse $ Just (Response {
  81                                                resVersion = HttpVersion 1 1
  82                                              , resStatus  = status
  83                                              , resHeaders = []
  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 ()