Network/HTTP/Lucu/Postprocess.hs

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