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                 writeTVar (itrWillClose itr) True
  58
  59            else
  60              do if reqVer == HttpVersion 1 0 then
  61                     -- HTTP/1.0 では Keep-Alive できない
  62                     writeTVar (itrWillClose itr) True
  63                   else
  64                     -- URI または Host: ヘッダのどちらかにホストが無ければ
  65                     -- ならない。
  66                     when (uriAuthority (reqURI req) == Nothing &&
  67                           getHeader req "Host"      == Nothing)
  68                              $ setStatus itr BadRequest
  69
  70                 case reqMethod req of
  71                   GET  -> return ()
  72                   HEAD -> writeTVar (itrWillDiscardBody itr) True
  73                   POST -> ensureHavingBody itr
  74                   PUT  -> ensureHavingBody itr
  75                   _    -> setStatus itr NotImplemented
  76
  77                 mapM_ (preprocessHeader itr) (reqHeaders req)
  78     where
  79       ensureHavingBody itr
  80           = let req = fromJust $ itrRequest itr
  81             in
  82               if getHeader req "Content-Length"    == Nothing &&
  83                  getHeader req "Transfer-Encoding" == Nothing then
  84
  85                   setStatus itr LengthRequired
  86               else
  87                   writeTVar (itrRequestHasBody itr) True
  88
  89       setStatus itr status
  90           = writeTVar (itrResponse itr) (Just $ Response {
  91                                                     resVersion = HttpVersion 1 1
  92                                                   , resStatus  = status
  93                                                   , resHeaders = []
  94                                                   })
  95
  96       preprocessHeader itr (name, value)
  97           = case map toLower name of
  98
  99               "expect"
 100                   -> if value `noCaseEq` "100-continue" then
 101                          writeTVar (itrExpectedContinue itr) True
 102                      else
 103                          setStatus itr ExpectationFailed
 104
 105               "transfer-encoding"
 106                   -> case map toLower value of
 107                        "identity" -> return ()
 108                        "chunked"  -> writeTVar (itrRequestIsChunked itr) True
 109                        _          -> setStatus itr NotImplemented
 110
 111               "content-length"
 112                   -> if all isDigit value then
 113                          writeTVar (itrRequestBodyLength itr) (Just $ read value)
 114                      else
 115                          setStatus itr BadRequest
 116
 117               "connection"
 118                   -> case map toLower value of
 119                        "close"      -> writeTVar (itrWillClose itr) True
 120                        _            -> return ()
 121
 122               _ -> return ()