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     application/octet-stream にする。出來ない時、HEAD でなければ
  46     Content-Type, Etag, Last-Modified を削除する。
  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 resM <- readItr itr itrResponse id
  63
  64          case resM of
  65            Nothing  -> writeItr itr itrResponse
  66                        $ Just $ Response {
  67                                resVersion = HttpVersion 1 1
  68                              , resStatus  = Ok
  69                              , resHeaders = []
  70                              }
  71            Just res -> do let sc = resStatus res
  72
  73                           when (not $ any (\ p -> p sc) [isSuccessful, isRedirection, isError])
  74                                    $ abortSTM InternalServerError []
  75                                          $ Just ("The status code is not good for a final status: "
  76                                                  ++ show sc)
  77
  78                           when (sc == MethodNotAllowed && getHeader "Allow" res == Nothing)
  79                                    $ abortSTM InternalServerError []
  80                                          $ Just ("The status was " ++ show sc ++ " but no Allow header.")
  81
  82                           when (sc /= NotModified && isRedirection sc && getHeader "Location" res == Nothing)
  83                                    $ abortSTM InternalServerError []
  84                                          $ Just ("The status code was " ++ show sc ++ " but no Location header.")
  85
  86          when (itrRequest itr /= Nothing)
  87               $ relyOnRequest itr
  88
  89          do oldRes <- readItr itr itrResponse id
  90             newRes <- unsafeIOToSTM
  91                       $ completeUnconditionalHeaders (itrConfig itr) (fromJust oldRes)
  92             writeItr itr itrResponse $ Just newRes
  93     where
  94       relyOnRequest :: Interaction -> STM ()
  95       relyOnRequest itr
  96           = do status <- readItr itr itrResponse (resStatus . fromJust)
  97
  98                let req         = fromJust $ itrRequest itr
  99                    reqVer      = reqVersion req
 100                    canHaveBody = if reqMethod req == HEAD then
 101                                      False
 102                                  else
 103                                      not (isInformational status ||
 104                                           status == NoContent    ||
 105                                           status == ResetContent ||
 106                                           status == NotModified    )
 107
 108                updateRes itr $ deleteHeader "Content-Length"
 109
 110                cType <- readHeader itr "Content-Type"
 111                when (cType == Nothing)
 112                         $ updateRes itr $ setHeader "Content-Type" "application/octet-stream"
 113
 114                if canHaveBody then
 115                    do teM <- readHeader itr "Transfer-Encoding"
 116                       if reqVer == HttpVersion 1 1 then
 117
 118                           do case teM of
 119                                Nothing -> updateRes itr $ setHeader "Transfer-Encoding" "chunked"
 120                                Just te -> let teList = [trim isWhiteSpace x
 121                                                             | x <- splitBy (== ',') (map toLower te)]
 122                                           in
 123                                             when (teList == [] || last teList /= "chunked")
 124                                                      $ abortSTM InternalServerError []
 125                                                            $ Just ("Transfer-Encoding must end with `chunked' "
 126                                                                    ++ "because this is an HTTP/1.1 request: "
 127                                                                    ++ te)
 128
 129                              writeItr itr itrWillChunkBody True
 130                         else
 131                           case fmap (map toLower) teM of
 132                             Nothing         -> return ()
 133                             Just "identity" -> return ()
 134                             Just te         -> abortSTM InternalServerError []
 135                                                $ Just ("Transfer-Encoding must be `identity' because "
 136                                                        ++ "this is an HTTP/1.0 request: "
 137                                                        ++ te)
 138                  else
 139                    -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
 140                    do updateRes itr $ deleteHeader "Transfer-Encoding"
 141                       when (reqMethod req /= HEAD)
 142                                $ do updateRes itr $ deleteHeader "Content-Type"
 143                                     updateRes itr $ deleteHeader "Etag"
 144                                     updateRes itr $ deleteHeader "Last-Modified"
 145
 146                conn <- readHeader itr "Connection"
 147                case fmap (map toLower) conn of
 148                  Just "close" -> writeItr itr itrWillClose True
 149                  _            -> return ()
 150
 151                willClose <- readItr itr itrWillClose id
 152                when willClose
 153                         $ updateRes itr $ setHeader "Connection" "close"
 154
 155                when (reqMethod req == HEAD || not canHaveBody)
 156                         $ writeTVar (itrWillDiscardBody itr) True
 157
 158       readHeader :: Interaction -> String -> STM (Maybe String)
 159       readHeader itr name
 160           = do valueMM <- readItrF itr itrResponse $ getHeader name
 161                case valueMM of
 162                  Just (Just val) -> return $ Just val
 163                  _               -> return Nothing
 164
 165       updateRes :: Interaction -> (Response -> Response) -> STM ()
 166       updateRes itr updator
 167           = updateItrF itr itrResponse updator
 168
 169
 170 completeUnconditionalHeaders :: Config -> Response -> IO Response
 171 completeUnconditionalHeaders conf res
 172     = return res >>= compServer >>= compDate >>= return
 173       where
 174         compServer res
 175             = case getHeader "Server" res of
 176                 Nothing -> return $ addHeader "Server" (cnfServerSoftware conf) res
 177                 Just _  -> return res
 178
 179         compDate res
 180             = case getHeader "Date" res of
 181                 Nothing -> do time <- getClockTime
 182                               return $ addHeader "Date" (formatHTTPDateTime time) res
 183                 Just _  -> return res