Network/HTTP/Lucu/Preprocess.hs

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