Network/HTTP/Lucu/Postprocess.hs

   1 -- #hide
   2 module Network.HTTP.Lucu.Postprocess
   3     ( postprocess
   4     , completeUnconditionalHeaders
   5     )
   6     where
   7
   8 import           Control.Concurrent.STM
   9 import           Control.Monad
  10 import           Data.Char
  11 import           Data.Maybe
  12 import           GHC.Conc (unsafeIOToSTM)
  13 import           Network.HTTP.Lucu.Abortion
  14 import           Network.HTTP.Lucu.Config
  15 import           Network.HTTP.Lucu.Headers
  16 import           Network.HTTP.Lucu.HttpVersion
  17 import           Network.HTTP.Lucu.Interaction
  18 import           Network.HTTP.Lucu.RFC1123DateTime
  19 import           Network.HTTP.Lucu.Request
  20 import           Network.HTTP.Lucu.Response
  21 import           System.Time
  22
  23 {-
  24
  25   * Response が未設定なら、200 OK にする。
  26
  27   * ステータスが 2xx, 3xx, 4xx, 5xx のいずれでもなければ 500 にする。
  28
  29   * 405 Method Not Allowed なのに Allow ヘッダが無ければ 500 にする。
  30
  31   * 304 Not Modified 以外の 3xx なのに Location ヘッダが無ければ 500 に
  32     する。
  33
  34   * Content-Length があれば、それを削除する。Transfer-Encoding があって
  35     も削除する。
  36
  37   * HTTP/1.1 であり、body を持つ事が出來る時、Transfer-Encoding を
  38     chunked に設定する。
  39
  40   * body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。
  41     出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除
  42     する。
  43
  44   * body を持つ事が出來ない時、body 破棄フラグを立てる。
  45
  46   * Connection: close が設定されてゐる時、切斷フラグを立てる。
  47
  48   * 切斷フラグが立ってゐる時、Connection: close を設定する。
  49
  50   * Server が無ければ設定。
  51
  52   * Date が無ければ設定。
  53
  54 -}
  55
  56 postprocess :: Interaction -> STM ()
  57 postprocess itr
  58     = itr `seq`
  59       do reqM <- readItr itr itrRequest id
  60          res  <- readItr itr itrResponse id
  61          let sc = resStatus res
  62
  63          when (not $ any (\ p -> p sc) [isSuccessful, isRedirection, isError])
  64                   $ abortSTM InternalServerError []
  65                         $ Just ("The status code is not good for a final status: "
  66                                 ++ show sc)
  67
  68          when (sc == MethodNotAllowed && getHeader "Allow" res == Nothing)
  69                   $ abortSTM InternalServerError []
  70                         $ Just ("The status was " ++ show sc ++ " but no Allow header.")
  71
  72          when (sc /= NotModified && isRedirection sc && getHeader "Location" res == Nothing)
  73                   $ abortSTM InternalServerError []
  74                         $ Just ("The status code was " ++ show sc ++ " but no Location header.")
  75
  76          when (reqM /= Nothing)
  77               $ relyOnRequest itr
  78
  79          -- itrResponse の内容は relyOnRequest によって變へられてゐる可
  80          -- 能性が高い。
  81          do oldRes <- readItr itr itrResponse id
  82             newRes <- unsafeIOToSTM
  83                       $ completeUnconditionalHeaders (itrConfig itr) oldRes
  84             writeItr itr itrResponse newRes
  85     where
  86       relyOnRequest :: Interaction -> STM ()
  87       relyOnRequest itr
  88           = itr `seq`
  89             do status <- readItr itr itrResponse resStatus
  90                req    <- readItr itr itrRequest fromJust
  91
  92                let reqVer      = reqVersion req
  93                    canHaveBody = if reqMethod req == HEAD then
  94                                      False
  95                                  else
  96                                      not (isInformational status ||
  97                                           status == NoContent    ||
  98                                           status == ResetContent ||
  99                                           status == NotModified    )
 100
 101                updateRes itr $! deleteHeader "Content-Length"
 102                updateRes itr $! deleteHeader "Transfer-Encoding"
 103
 104                cType <- readHeader itr "Content-Type"
 105                when (cType == Nothing)
 106                         $ updateRes itr $ setHeader "Content-Type" defaultPageContentType
 107
 108                if canHaveBody then
 109                    when (reqVer == HttpVersion 1 1)
 110                             $ do updateRes itr $! setHeader "Transfer-Encoding" "chunked"
 111                                  writeItr itr itrWillChunkBody True
 112                  else
 113                    -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
 114                    when (reqMethod req /= HEAD)
 115                             $ do updateRes itr $! deleteHeader "Content-Type"
 116                                  updateRes itr $! deleteHeader "Etag"
 117                                  updateRes itr $! deleteHeader "Last-Modified"
 118
 119                conn <- readHeader itr "Connection"
 120                case fmap (map toLower) conn of
 121                  Just "close" -> writeItr itr itrWillClose True
 122                  _            -> return ()
 123
 124                willClose <- readItr itr itrWillClose id
 125                when willClose
 126                         $ updateRes itr $! setHeader "Connection" "close"
 127
 128                when (reqMethod req == HEAD || not canHaveBody)
 129                         $ writeTVar (itrWillDiscardBody itr) True
 130
 131       readHeader :: Interaction -> String -> STM (Maybe String)
 132       readHeader itr name
 133           = itr `seq` name `seq`
 134             readItr itr itrResponse $ getHeader name
 135
 136       updateRes :: Interaction -> (Response -> Response) -> STM ()
 137       updateRes itr updator
 138           = itr `seq` updator `seq`
 139             updateItr itr itrResponse updator
 140
 141
 142 completeUnconditionalHeaders :: Config -> Response -> IO Response
 143 completeUnconditionalHeaders conf res
 144     = conf `seq` res `seq`
 145       return res >>= compServer >>= compDate >>= return
 146       where
 147         compServer res
 148             = case getHeader "Server" res of
 149                 Nothing -> return $ addHeader "Server" (cnfServerSoftware conf) res
 150                 Just _  -> return res
 151
 152         compDate res
 153             = case getHeader "Date" res of
 154                 Nothing -> do time <- getClockTime
 155                               return $ addHeader "Date" (formatHTTPDateTime time) res
 156                 Just _  -> return res