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 があれば、それを削除する。
  36
  37   * HTTP/1.1 であり、且つ body を持つ事が出來る時、Transfer-Encoding の
  38     最後の要素が chunked でなければ 500 Internal Error にする。
  39     Transfer-Encoding が未設定であれば、chunked に設定する。
  40
  41   * HTTP/1.0 なのに Transfer-Encoding が設定濟なら 500 Internal Server
  42     Error にする。但し identity だけは許す。
  43
  44   * body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。
  45     出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除
  46     する。
  47
  48   * body を持つ事が出來ない時、body 破棄フラグを立てる。
  49
  50   * Connection: close が設定されてゐる時、切斷フラグを立てる。
  51
  52   * 切斷フラグが立ってゐる時、Connection: close を設定する。
  53
  54   * Server が無ければ設定。
  55
  56   * Date が無ければ設定。
  57
  58 -}
  59
  60 postprocess :: Interaction -> STM ()
  61 postprocess itr
  62     = do res <- readItr itr itrResponse id
  63          let sc = resStatus res
  64
  65          when (not $ any (\ p -> p sc) [isSuccessful, isRedirection, isError])
  66                   $ abortSTM InternalServerError []
  67                         $ Just ("The status code is not good for a final status: "
  68                                 ++ show sc)
  69
  70          when (sc == MethodNotAllowed && getHeader "Allow" res == Nothing)
  71                   $ abortSTM InternalServerError []
  72                         $ Just ("The status was " ++ show sc ++ " but no Allow header.")
  73
  74          when (sc /= NotModified && isRedirection sc && getHeader "Location" res == Nothing)
  75                   $ abortSTM InternalServerError []
  76                         $ Just ("The status code was " ++ show sc ++ " but no Location header.")
  77
  78          when (itrRequest itr /= Nothing)
  79               $ relyOnRequest itr
  80
  81          do newRes <- unsafeIOToSTM
  82                       $ completeUnconditionalHeaders (itrConfig itr) res
  83             writeItr itr itrResponse newRes
  84     where
  85       relyOnRequest :: Interaction -> STM ()
  86       relyOnRequest itr
  87           = do status <- readItr itr itrResponse resStatus
  88
  89                let req         = fromJust $ itrRequest itr
  90                    reqVer      = reqVersion req
  91                    canHaveBody = if reqMethod req == HEAD then
  92                                      False
  93                                  else
  94                                      not (isInformational status ||
  95                                           status == NoContent    ||
  96                                           status == ResetContent ||
  97                                           status == NotModified    )
  98
  99                updateRes itr $ deleteHeader "Content-Length"
 100
 101                cType <- readHeader itr "Content-Type"
 102                when (cType == Nothing)
 103                         $ updateRes itr $ setHeader "Content-Type" defaultPageContentType
 104
 105                if canHaveBody then
 106                    do teM <- readHeader itr "Transfer-Encoding"
 107                       if reqVer == HttpVersion 1 1 then
 108
 109                           do case teM of
 110                                Nothing -> updateRes itr $ setHeader "Transfer-Encoding" "chunked"
 111                                Just te -> let teList = [trim isWhiteSpace x
 112                                                             | x <- splitBy (== ',') (map toLower te)]
 113                                           in
 114                                             when (teList == [] || last teList /= "chunked")
 115                                                      $ abortSTM InternalServerError []
 116                                                            $ Just ("Transfer-Encoding must end with `chunked' "
 117                                                                    ++ "because this is an HTTP/1.1 request: "
 118                                                                    ++ te)
 119
 120                              writeItr itr itrWillChunkBody True
 121                         else
 122                           case fmap (map toLower) teM of
 123                             Nothing         -> return ()
 124                             Just "identity" -> return ()
 125                             Just te         -> abortSTM InternalServerError []
 126                                                $ Just ("Transfer-Encoding must be `identity' because "
 127                                                        ++ "this is an HTTP/1.0 request: "
 128                                                        ++ te)
 129                  else
 130                    -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
 131                    do updateRes itr $ deleteHeader "Transfer-Encoding"
 132                       when (reqMethod req /= HEAD)
 133                                $ do updateRes itr $ deleteHeader "Content-Type"
 134                                     updateRes itr $ deleteHeader "Etag"
 135                                     updateRes itr $ deleteHeader "Last-Modified"
 136
 137                conn <- readHeader itr "Connection"
 138                case fmap (map toLower) conn of
 139                  Just "close" -> writeItr itr itrWillClose True
 140                  _            -> return ()
 141
 142                willClose <- readItr itr itrWillClose id
 143                when willClose
 144                         $ updateRes itr $ setHeader "Connection" "close"
 145
 146                when (reqMethod req == HEAD || not canHaveBody)
 147                         $ writeTVar (itrWillDiscardBody itr) True
 148
 149       readHeader :: Interaction -> String -> STM (Maybe String)
 150       readHeader itr name
 151           = readItr itr itrResponse $ getHeader name
 152
 153       updateRes :: Interaction -> (Response -> Response) -> STM ()
 154       updateRes itr updator
 155           = updateItr itr itrResponse updator
 156
 157
 158 completeUnconditionalHeaders :: Config -> Response -> IO Response
 159 completeUnconditionalHeaders conf res
 160     = return res >>= compServer >>= compDate >>= return
 161       where
 162         compServer res
 163             = case getHeader "Server" res of
 164                 Nothing -> return $ addHeader "Server" (cnfServerSoftware conf) res
 165                 Just _  -> return res
 166
 167         compDate res
 168             = case getHeader "Date" res of
 169                 Nothing -> do time <- getClockTime
 170                               return $ addHeader "Date" (formatHTTPDateTime time) res
 171                 Just _  -> return res