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