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.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                   DELETE -> return ()
  76                   _      -> setStatus NotImplemented
  77
  78                 preprocessHeader req
  79     where
  80       setStatus :: StatusCode -> STM ()
  81       setStatus !status
  82           = updateItr itr itrResponse
  83             $! \ res -> res {
  84                           resStatus = status
  85                         }
  86
  87       completeAuthority :: Request -> STM ()
  88       completeAuthority !req
  89           = when (uriAuthority (reqURI req) == Nothing)
  90             $ if reqVersion req == HttpVersion 1 0 then
  91                   -- HTTP/1.0 なので Config から補完
  92                   do let conf = itrConfig itr
  93                          host = cnfServerHost conf
  94                          port = itrLocalPort itr
  95                          portStr
  96                               = case port of
  97                                   80 -> ""
  98                                   n  -> ':' : show n
  99                      updateAuthority host (C8.pack portStr)
 100               else
 101                   case getHeader (C8.pack "Host") req of
 102                     Just str -> let (host, portStr) = parseHost str
 103                                 in updateAuthority host portStr
 104                     Nothing  -> setStatus BadRequest
 105
 106
 107       parseHost :: Strict.ByteString -> (Strict.ByteString, Strict.ByteString)
 108       parseHost = C8.break (== ':')
 109
 110
 111       updateAuthority :: Strict.ByteString -> Strict.ByteString -> STM ()
 112       updateAuthority host portStr
 113           = host `seq` portStr `seq`
 114             updateItr itr itrRequest
 115             $! \ (Just req) -> Just req {
 116                                  reqURI = let uri = reqURI req
 117                                           in uri {
 118                                                uriAuthority = Just URIAuth {
 119                                                                    uriUserInfo = ""
 120                                                                  , uriRegName  = C8.unpack host
 121                                                                  , uriPort     = C8.unpack portStr
 122                                                               }
 123                                              }
 124                                }
 125
 126
 127       preprocessHeader :: Request -> STM ()
 128       preprocessHeader req
 129           = req `seq`
 130             do case getHeader (C8.pack "Expect") req of
 131                  Nothing    -> return ()
 132                  Just value -> if value `noCaseEq` C8.pack "100-continue" then
 133                                    writeItr itr itrExpectedContinue True
 134                                else
 135                                    setStatus ExpectationFailed
 136
 137                case getHeader (C8.pack "Transfer-Encoding") req of
 138                  Nothing    -> return ()
 139                  Just value -> unless (value `noCaseEq` C8.pack "identity")
 140                                    $ if value `noCaseEq` C8.pack "chunked" then
 141                                          writeItr itr itrRequestIsChunked True
 142                                      else
 143                                          setStatus NotImplemented
 144
 145                case getHeader (C8.pack "Content-Length") req of
 146                  Nothing    -> return ()
 147                  Just value -> if C8.all isDigit value then
 148                                    do let Just (len, _) = C8.readInt value
 149                                       writeItr itr itrReqChunkLength    $ Just len
 150                                       writeItr itr itrReqChunkRemaining $ Just len
 151                                else
 152                                    setStatus BadRequest
 153
 154                case getHeader (C8.pack "Connection") req of
 155                  Nothing    -> return ()
 156                  Just value -> when (value `noCaseEq` C8.pack "close")
 157                                    $ writeItr itr itrWillClose True