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 import GHC.Conc (unsafeIOToSTM)
  51
  52 preprocess :: Interaction -> STM ()
  53 preprocess itr
  54     = itr `seq`
  55       do req <- readItr itr itrRequest fromJust
  56
  57          let reqVer = reqVersion req
  58
  59          if reqVer /= HttpVersion 1 0 &&
  60             reqVer /= HttpVersion 1 1 then
  61
  62              do setStatus HttpVersionNotSupported
  63                 writeItr itr itrWillClose True
  64
  65            else
  66              -- HTTP/1.0 では Keep-Alive できない
  67              do when (reqVer == HttpVersion 1 0)
  68                      $ writeItr itr itrWillClose True
  69
  70                 -- ホスト部の補完
  71                 completeAuthority req
  72
  73                 case reqMethod req of
  74                   GET  -> return ()
  75                   HEAD -> writeItr itr itrWillDiscardBody True
  76                   POST -> writeItr itr itrRequestHasBody True
  77                   PUT  -> writeItr itr itrRequestHasBody True
  78                   _    -> setStatus NotImplemented
  79
  80                 mapM_ (preprocessHeader itr) (reqHeaders req)
  81     where
  82       setStatus :: StatusCode -> STM ()
  83       setStatus status
  84           = status `seq`
  85             updateItr itr itrResponse
  86             $! \ res -> res {
  87                           resStatus = status
  88                         }
  89
  90       completeAuthority :: Request -> STM ()
  91       completeAuthority req
  92           = req `seq`
  93             when (uriAuthority (reqURI req) == Nothing)
  94             $ if reqVersion req == HttpVersion 1 0 then
  95                   -- HTTP/1.0 なので Config から補完
  96                   do let conf = itrConfig itr
  97                          host = cnfServerHost conf
  98                          port = case cnfServerPort conf of
  99                                   PortNumber n -> Just $ fromIntegral n
 100                                   _            -> Nothing
 101                          portStr
 102                               = case port of
 103                                   Just 80 -> Just ""
 104                                   Just n  -> Just $ ":" ++ show n
 105                                   Nothing -> Nothing
 106                      case portStr of
 107                        Just str -> updateAuthority host str
 108                        -- FIXME: このエラーの原因は、listen してゐるソ
 109                        -- ケットが INET でない故にポート番號が分からな
 110                        -- い事だが、その事をどうにかして通知した方が良
 111                        -- いと思ふ。stderr？
 112                        Nothing  -> setStatus InternalServerError
 113               else
 114                   do case getHeader "Host" req of
 115                        Just str -> let (host, portStr) = parseHost str
 116                                    in updateAuthority host portStr
 117                        Nothing  -> setStatus BadRequest
 118
 119
 120       parseHost :: String -> (String, String)
 121       parseHost = break (== ':')
 122
 123
 124       updateAuthority :: String -> String -> STM ()
 125       updateAuthority host portStr
 126           = host `seq` portStr `seq`
 127             updateItr itr itrRequest
 128             $! \ (Just req) -> Just req {
 129                                  reqURI = let uri = reqURI req
 130                                           in uri {
 131                                                uriAuthority = Just URIAuth {
 132                                                                    uriUserInfo = ""
 133                                                                  , uriRegName  = host
 134                                                                  , uriPort     = portStr
 135                                                               }
 136                                              }
 137                                }
 138
 139
 140       preprocessHeader :: Interaction -> (String, String) -> STM ()
 141       preprocessHeader itr (name, value)
 142           = itr `seq` name `seq` value `seq`
 143             case map toLower name of
 144
 145               "expect"
 146                   -> if value `noCaseEq'` "100-continue" then
 147                          writeItr itr itrExpectedContinue True
 148                      else
 149                          setStatus ExpectationFailed
 150
 151               "transfer-encoding"
 152                   -> case map toLower value of
 153                        "identity" -> return ()
 154                        "chunked"  -> writeItr itr itrRequestIsChunked True
 155                        _          -> setStatus NotImplemented
 156
 157               "content-length"
 158                   -> if all isDigit value then
 159                          do let len = read value
 160                             writeItr itr itrReqChunkLength    $ Just len
 161                             writeItr itr itrReqChunkRemaining $ Just len
 162                      else
 163                          setStatus BadRequest
 164
 165               "connection"
 166                   -> case map toLower value of
 167                        "close"      -> writeItr itr itrWillClose True
 168                        _            -> return ()
 169
 170               _ -> return ()