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     = do req <- readItr itr itrRequest fromJust
  55
  56          let reqVer = reqVersion req
  57
  58          if reqVer /= HttpVersion 1 0 &&
  59             reqVer /= HttpVersion 1 1 then
  60
  61              do setStatus HttpVersionNotSupported
  62                 writeItr itr itrWillClose True
  63
  64            else
  65              -- HTTP/1.0 では Keep-Alive できない
  66              do when (reqVer == HttpVersion 1 0)
  67                      $ writeItr itr itrWillClose True
  68
  69                 -- ホスト部の補完
  70                 completeAuthority req
  71
  72                 case reqMethod req of
  73                   GET  -> return ()
  74                   HEAD -> writeItr itr itrWillDiscardBody True
  75                   POST -> writeItr itr itrRequestHasBody True
  76                   PUT  -> writeItr itr itrRequestHasBody True
  77                   _    -> setStatus NotImplemented
  78
  79                 mapM_ (preprocessHeader itr) (reqHeaders req)
  80     where
  81       setStatus :: StatusCode -> STM ()
  82       setStatus status
  83           = updateItr itr itrResponse
  84             $ \ res -> res {
  85                          resStatus = status
  86                        }
  87
  88       completeAuthority :: Request -> STM ()
  89       completeAuthority req
  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           = updateItr itr itrRequest
 124             $ \ (Just req) -> Just req {
 125                                 reqURI = let uri = reqURI req
 126                                          in uri {
 127                                               uriAuthority = Just URIAuth {
 128                                                                   uriUserInfo = ""
 129                                                                 , uriRegName  = host
 130                                                                 , uriPort     = portStr
 131                                                                 }
 132                                             }
 133                               }
 134
 135
 136       preprocessHeader itr (name, value)
 137           = case map toLower name of
 138
 139               "expect"
 140                   -> if value `noCaseEq` "100-continue" then
 141                          writeItr itr itrExpectedContinue True
 142                      else
 143                          setStatus ExpectationFailed
 144
 145               "transfer-encoding"
 146                   -> case map toLower value of
 147                        "identity" -> return ()
 148                        "chunked"  -> writeItr itr itrRequestIsChunked True
 149                        _          -> setStatus NotImplemented
 150
 151               "content-length"
 152                   -> if all isDigit value then
 153                          do let len = read value
 154                             writeItr itr itrReqChunkLength    $ Just len
 155                             writeItr itr itrReqChunkRemaining $ Just len
 156                      else
 157                          setStatus BadRequest
 158
 159               "connection"
 160                   -> case map toLower value of
 161                        "close"      -> writeItr itr itrWillClose True
 162                        _            -> return ()
 163
 164               _ -> return ()