Network/HTTP/Lucu/Postprocess.hs

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