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.Config
  12 import           Network.HTTP.Lucu.Headers
  13 import           Network.HTTP.Lucu.HttpVersion
  14 import           Network.HTTP.Lucu.Interaction
  15 import           Network.HTTP.Lucu.Request
  16 import           Network.HTTP.Lucu.Response
  17 import           Network.HTTP.Lucu.Utils
  18 import           Network
  19 import           Network.URI
  20
  21 {-
  22
  23   * URI にホスト名が存在しない時、
  24     [1] HTTP/1.0 ならば Config を使って補完
  25     [2] HTTP/1.1 ならば Host ヘッダで補完。Host が無ければ 400。
  26
  27   * Expect: に問題があった場合は 417 Expectation Failed に設定。
  28     100-continue 以外のものは全部 417 に。
  29
  30   * Transfer-Encoding: に問題があったら 501 Not Implemented にする。具
  31     体的には、identity でも chunked でもなければ 501 Not Implemented に
  32     する。
  33
  34   * メソッドが GET, HEAD, POST, PUT, DELETE の何れでもない場合は 501
  35     Not Implemented にする。
  36
  37   * HTTP/1.0 でも HTTP/1.1 でもないリクエストに對しては 505 HTTP
  38     Version Not Supported を返す。
  39
  40   * POST または PUT に Content-Length も Transfer-Encoding も無い時は、
  41     411 Length Required にする。
  42
  43   * Content-Length の値が數値でなかったり負だったりしたら 400 Bad
  44     Request にする。
  45
  46   * willDiscardBody その他の變數を設定する。
  47
  48 -}
  49
  50 preprocess :: Interaction -> STM ()
  51 preprocess itr
  52     = itr `seq`
  53       do req <- readItr itr itrRequest fromJust
  54
  55          let reqVer = reqVersion req
  56
  57          if reqVer /= HttpVersion 1 0 &&
  58             reqVer /= HttpVersion 1 1 then
  59
  60              do setStatus HttpVersionNotSupported
  61                 writeItr itr itrWillClose True
  62
  63            else
  64              -- HTTP/1.0 では Keep-Alive できない
  65              do when (reqVer == HttpVersion 1 0)
  66                      $ writeItr itr itrWillClose True
  67
  68                 -- ホスト部の補完
  69                 completeAuthority req
  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 NotImplemented
  77
  78                 mapM_ (preprocessHeader itr) (reqHeaders req)
  79     where
  80       setStatus :: StatusCode -> STM ()
  81       setStatus status
  82           = status `seq`
  83             updateItr itr itrResponse
  84             $! \ res -> res {
  85                           resStatus = status
  86                         }
  87
  88       completeAuthority :: Request -> STM ()
  89       completeAuthority req
  90           = req `seq`
  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 = case cnfServerPort conf of
  97                                   PortNumber n -> Just $ fromIntegral n
  98                                   _            -> Nothing
  99                          portStr
 100                               = case port of
 101                                   Just 80 -> Just ""
 102                                   Just n  -> Just $ ":" ++ show n
 103                                   Nothing -> Nothing
 104                      case portStr of
 105                        Just str -> updateAuthority host str
 106                        -- FIXME: このエラーの原因は、listen してゐるソ
 107                        -- ケットが INET でない故にポート番號が分からな
 108                        -- い事だが、その事をどうにかして通知した方が良
 109                        -- いと思ふ。stderr？
 110                        Nothing  -> setStatus InternalServerError
 111               else
 112                   do case getHeader "Host" req of
 113                        Just str -> let (host, portStr) = parseHost str
 114                                    in updateAuthority host portStr
 115                        Nothing  -> setStatus BadRequest
 116
 117
 118       parseHost :: String -> (String, String)
 119       parseHost = break (== ':')
 120
 121
 122       updateAuthority :: String -> String -> STM ()
 123       updateAuthority host portStr
 124           = host `seq` portStr `seq`
 125             updateItr itr itrRequest
 126             $! \ (Just req) -> Just req {
 127                                  reqURI = let uri = reqURI req
 128                                           in uri {
 129                                                uriAuthority = Just URIAuth {
 130                                                                    uriUserInfo = ""
 131                                                                  , uriRegName  = host
 132                                                                  , uriPort     = portStr
 133                                                               }
 134                                              }
 135                                }
 136
 137
 138       preprocessHeader :: Interaction -> (String, String) -> STM ()
 139       preprocessHeader itr (name, value)
 140           = itr `seq` name `seq` value `seq`
 141             case map toLower name of
 142
 143               "expect"
 144                   -> if value `noCaseEq'` "100-continue" then
 145                          writeItr itr itrExpectedContinue True
 146                      else
 147                          setStatus ExpectationFailed
 148
 149               "transfer-encoding"
 150                   -> case map toLower value of
 151                        "identity" -> return ()
 152                        "chunked"  -> writeItr itr itrRequestIsChunked True
 153                        _          -> setStatus NotImplemented
 154
 155               "content-length"
 156                   -> if all isDigit value then
 157                          do let len = read value
 158                             writeItr itr itrReqChunkLength    $ Just len
 159                             writeItr itr itrReqChunkRemaining $ Just len
 160                      else
 161                          setStatus BadRequest
 162
 163               "connection"
 164                   -> case map toLower value of
 165                        "close"      -> writeItr itr itrWillClose True
 166                        _            -> return ()
 167
 168               _ -> return ()