Network/HTTP/Lucu/Postprocess.hs

   1 module Network.HTTP.Lucu.Postprocess
   2     ( postprocess -- Interaction -> STM ()
   3     , completeUnconditionalHeaders -- 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.Headers
  13 import           Network.HTTP.Lucu.HttpVersion
  14 import           Network.HTTP.Lucu.Interaction
  15 import           Network.HTTP.Lucu.RFC1123DateTime
  16 import           Network.HTTP.Lucu.Request
  17 import           Network.HTTP.Lucu.Response
  18 import           Network.HTTP.Lucu.Utils
  19 import           System.Time
  20
  21 {-
  22
  23   * Response が未設定なら、HTTP/1.1 500 Internal Server Error にする。
  24
  25   * Content-Length があれば、それを削除する。
  26
  27   * HTTP/1.1 であり、且つ body を持つ事が出來る時、Transfer-Encoding の
  28     最後の要素が chunked でなければ 500 Internal Error にする。
  29     Transfer-Encoding が未設定であれば、chunked に設定する。
  30
  31   * HTTP/1.0 なのに Transfer-Encoding が設定濟なら 500 Internal Server
  32     Error にする。但し identity だけは許す。
  33
  34   * body を持つ事が出來る時、Content-Type が無ければ
  35     application/octet-stream にする。出來ない時、HEAD でなければ
  36     Content-Type を削除する。
  37
  38   * body を持つ事が出來ない時、body 破棄フラグを立てる。
  39
  40   * Connection: close が設定されてゐる時、切斷フラグを立てる。
  41
  42   * 切斷フラグが立ってゐる時、Connection: close を設定する。
  43
  44   * Server が無ければ設定。
  45
  46   * Date が無ければ設定。
  47
  48 -}
  49
  50 {- Postprocess は body を補完した後で實行する事 -}
  51
  52 postprocess :: Interaction -> STM ()
  53 postprocess itr
  54     = do res <- readItr itr itrResponse id
  55
  56          when (res == Nothing)
  57               $ setStatus itr InternalServerError
  58
  59          when (itrRequest itr /= Nothing)
  60               $ relyOnRequest itr
  61
  62          do oldRes <- readItr itr itrResponse id
  63             newRes <- unsafeIOToSTM $ completeUnconditionalHeaders $ fromJust oldRes
  64             writeItr itr itrResponse $ Just newRes
  65     where
  66       relyOnRequest itr
  67           = do status <- readItr itr itrResponse (resStatus . fromJust)
  68
  69                let req         = fromJust $ itrRequest itr
  70                    reqVer      = reqVersion req
  71                    canHaveBody = if reqMethod req == HEAD then
  72                                      False
  73                                  else
  74                                      not (isInformational status ||
  75                                           status == NoContent    ||
  76                                           status == ResetContent ||
  77                                           status == NotModified    )
  78
  79                updateRes itr $ deleteHeader "Content-Length"
  80
  81                if canHaveBody then
  82                    do teM <- readHeader itr "Transfer-Encoding"
  83                       if reqVer == HttpVersion 1 1 then
  84
  85                           do case teM of
  86                                Nothing -> updateRes itr $ setHeader "Transfer-Encoding" "chunked"
  87                                Just te -> let teList = [trim isWhiteSpace x
  88                                                             | x <- splitBy (== ',') (map toLower te)]
  89                                           in
  90                                             when (teList == [] || last teList /= "chunked")
  91                                                      $ setStatus itr InternalServerError
  92
  93                              writeItr itr itrWillChunkBody True
  94                         else
  95                           case fmap (map toLower) teM of
  96                             Nothing         -> return ()
  97                             Just "identity" -> return ()
  98                             _               -> setStatus itr InternalServerError
  99
 100                       cType <- readHeader itr "Content-Type"
 101                       when (cType == Nothing)
 102                                $ updateRes itr $ setHeader "Content-Type" "application/octet-stream"
 103                  else
 104                    -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
 105                    do updateRes itr $ deleteHeader "Transfer-Encoding"
 106                       when (reqMethod req /= HEAD)
 107                                $ updateRes itr $ deleteHeader "Content-Type"
 108
 109                conn <- readHeader itr "Connection"
 110                case fmap (map toLower) conn of
 111                  Just "close" -> writeItr itr itrWillClose True
 112                  _            -> updateRes itr $ setHeader "Connection" "close"
 113
 114                when (reqMethod req == HEAD || not canHaveBody)
 115                         $ writeTVar (itrWillDiscardBody itr) True
 116
 117       setStatus :: Interaction -> StatusCode -> STM ()
 118       setStatus itr status
 119           = writeTVar (itrResponse itr) (Just $ Response {
 120                                                     resVersion = HttpVersion 1 1
 121                                                   , resStatus  = status
 122                                                   , resHeaders = []
 123                                                   })
 124
 125       readHeader :: Interaction -> String -> STM (Maybe String)
 126       readHeader itr name
 127           = do valueMM <- readItrF itr itrResponse $ getHeader name
 128                case valueMM of
 129                  Just (Just val) -> return $ Just val
 130                  _               -> return Nothing
 131
 132       updateRes :: Interaction -> (Response -> Response) -> STM ()
 133       updateRes itr updator
 134           = updateItrF itr itrResponse updator
 135
 136
 137 completeUnconditionalHeaders :: Response -> IO Response
 138 completeUnconditionalHeaders res
 139     = return res >>= compServer >>= compDate >>= return
 140       where
 141         compServer res
 142             = case getHeader "Server" res of
 143                 Nothing -> return $ addHeader "Server" "Lucu/1.0" res
 144                 Just _  -> return res
 145
 146         compDate res
 147             = case getHeader "Date" res of
 148                 Nothing -> do time <- getClockTime
 149                               return $ addHeader "Date" (formatHTTPDateTime time) res
 150                 Just _  -> return res