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 qualified Data.ByteString as Strict (ByteString)
   9 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
  10 import           Data.Char
  11 import           Data.Maybe
  12 import           Network.HTTP.Lucu.Config
  13 import           Network.HTTP.Lucu.Headers
  14 import           Network.HTTP.Lucu.HttpVersion
  15 import           Network.HTTP.Lucu.Interaction
  16 import           Network.HTTP.Lucu.Request
  17 import           Network.HTTP.Lucu.Response
  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                 preprocessHeader 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 :: Int)
  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 (C8.pack str)
 106                        -- FIXME: このエラーの原因は、listen してゐるソ
 107                        -- ケットが INET でない故にポート番號が分からな
 108                        -- い事だが、その事をどうにかして通知した方が良
 109                        -- いと思ふ。stderr？
 110                        Nothing  -> setStatus InternalServerError
 111               else
 112                   do case getHeader (C8.pack "Host") req of
 113                        Just str -> let (host, portStr) = parseHost str
 114                                    in updateAuthority host portStr
 115                        Nothing  -> setStatus BadRequest
 116
 117
 118       parseHost :: Strict.ByteString -> (Strict.ByteString, Strict.ByteString)
 119       parseHost = C8.break (== ':')
 120
 121
 122       updateAuthority :: Strict.ByteString -> Strict.ByteString -> 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  = C8.unpack host
 132                                                                  , uriPort     = C8.unpack portStr
 133                                                               }
 134                                              }
 135                                }
 136
 137
 138       preprocessHeader :: Request -> STM ()
 139       preprocessHeader req
 140           = req `seq`
 141             do case getHeader (C8.pack "Expect") req of
 142                  Nothing    -> return ()
 143                  Just value -> if value `noCaseEq` C8.pack "100-continue" then
 144                                    writeItr itr itrExpectedContinue True
 145                                else
 146                                    setStatus ExpectationFailed
 147
 148                case getHeader (C8.pack "Transfer-Encoding") req of
 149                  Nothing    -> return ()
 150                  Just value -> if value `noCaseEq` C8.pack "identity" then
 151                                    return ()
 152                                else
 153                                    if value `noCaseEq` C8.pack "chunked" then
 154                                        writeItr itr itrRequestIsChunked True
 155                                    else
 156                                        setStatus NotImplemented
 157
 158                case getHeader (C8.pack "Content-Length") req of
 159                  Nothing    -> return ()
 160                  Just value -> if C8.all isDigit value then
 161                                    do let Just (len, _) = C8.readInt value
 162                                       writeItr itr itrReqChunkLength    $ Just len
 163                                       writeItr itr itrReqChunkRemaining $ Just len
 164                                else
 165                                    setStatus BadRequest
 166
 167                case getHeader (C8.pack "Connection") req of
 168                  Nothing    -> return ()
 169                  Just value -> if value `noCaseEq` C8.pack "close" then
 170                                    writeItr itr itrWillClose True
 171                                else
 172                                    return ()