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                   DELETE -> return ()
  77                   _      -> setStatus NotImplemented
  78
  79                 preprocessHeader req
  80     where
  81       setStatus :: StatusCode -> STM ()
  82       setStatus status
  83           = status `seq`
  84             updateItr itr itrResponse
  85             $! \ res -> res {
  86                           resStatus = status
  87                         }
  88
  89       completeAuthority :: Request -> STM ()
  90       completeAuthority req
  91           = req `seq`
  92             when (uriAuthority (reqURI req) == Nothing)
  93             $ if reqVersion req == HttpVersion 1 0 then
  94                   -- HTTP/1.0 なので Config から補完
  95                   do let conf = itrConfig itr
  96                          host = cnfServerHost conf
  97                          port = case cnfServerPort conf of
  98                                   PortNumber n -> Just (fromIntegral n :: Int)
  99                                   _            -> Nothing
 100                          portStr
 101                               = case port of
 102                                   Just 80 -> Just ""
 103                                   Just n  -> Just $ ":" ++ show n
 104                                   Nothing -> Nothing
 105                      case portStr of
 106                        Just str -> updateAuthority host (C8.pack str)
 107                        -- FIXME: このエラーの原因は、listen してゐるソ
 108                        -- ケットが INET でない故にポート番號が分からな
 109                        -- い事だが、その事をどうにかして通知した方が良
 110                        -- いと思ふ。stderr？
 111                        Nothing  -> setStatus InternalServerError
 112               else
 113                   do case getHeader (C8.pack "Host") req of
 114                        Just str -> let (host, portStr) = parseHost str
 115                                    in updateAuthority host portStr
 116                        Nothing  -> setStatus BadRequest
 117
 118
 119       parseHost :: Strict.ByteString -> (Strict.ByteString, Strict.ByteString)
 120       parseHost = C8.break (== ':')
 121
 122
 123       updateAuthority :: Strict.ByteString -> Strict.ByteString -> STM ()
 124       updateAuthority host portStr
 125           = host `seq` portStr `seq`
 126             updateItr itr itrRequest
 127             $! \ (Just req) -> Just req {
 128                                  reqURI = let uri = reqURI req
 129                                           in uri {
 130                                                uriAuthority = Just URIAuth {
 131                                                                    uriUserInfo = ""
 132                                                                  , uriRegName  = C8.unpack host
 133                                                                  , uriPort     = C8.unpack portStr
 134                                                               }
 135                                              }
 136                                }
 137
 138
 139       preprocessHeader :: Request -> STM ()
 140       preprocessHeader req
 141           = req `seq`
 142             do case getHeader (C8.pack "Expect") req of
 143                  Nothing    -> return ()
 144                  Just value -> if value `noCaseEq` C8.pack "100-continue" then
 145                                    writeItr itr itrExpectedContinue True
 146                                else
 147                                    setStatus ExpectationFailed
 148
 149                case getHeader (C8.pack "Transfer-Encoding") req of
 150                  Nothing    -> return ()
 151                  Just value -> if value `noCaseEq` C8.pack "identity" then
 152                                    return ()
 153                                else
 154                                    if value `noCaseEq` C8.pack "chunked" then
 155                                        writeItr itr itrRequestIsChunked True
 156                                    else
 157                                        setStatus NotImplemented
 158
 159                case getHeader (C8.pack "Content-Length") req of
 160                  Nothing    -> return ()
 161                  Just value -> if C8.all isDigit value then
 162                                    do let Just (len, _) = C8.readInt value
 163                                       writeItr itr itrReqChunkLength    $ Just len
 164                                       writeItr itr itrReqChunkRemaining $ Just len
 165                                else
 166                                    setStatus BadRequest
 167
 168                case getHeader (C8.pack "Connection") req of
 169                  Nothing    -> return ()
 170                  Just value -> if value `noCaseEq` C8.pack "close" then
 171                                    writeItr itr itrWillClose True
 172                                else
 173                                    return ()