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 <- readTVar (itrResponse itr)
  55
  56          when (res == Nothing)
  57               $ setStatus itr InternalServerError
  58
  59          when (itrRequest itr /= Nothing)
  60               $ relyOnRequest itr
  61
  62          do oldRes <- readTVar (itrResponse itr)
  63             newRes <- unsafeIOToSTM $ completeUnconditionalHeaders $ fromJust oldRes
  64             setRes itr newRes
  65     where
  66       relyOnRequest itr
  67           = do resM <- readTVar (itrResponse itr)
  68
  69                let req         = fromJust $ itrRequest itr
  70                    reqVer      = reqVersion req
  71                    res         = fromJust resM
  72                    status      = resStatus res
  73                    canHaveBody = if reqMethod req == HEAD then
  74                                      False
  75                                  else
  76                                      isInformational status ||
  77                                      status == NoContent    ||
  78                                      status == ResetContent ||
  79                                      status == NotModified
  80
  81                setRes itr (deleteHeader res "Content-Length")
  82
  83                if canHaveBody then
  84                    do if reqVer == HttpVersion 1 1 then
  85
  86                           case getHeader res "Transfer-Encoding" of
  87                             Nothing -> setRes itr (setHeader res "Transfer-Encoding" "chunked")
  88                             Just te -> let teList = [trim isWhiteSpace x
  89                                                          | x <- splitBy (== ',') (map toLower te)]
  90                                        in
  91                                          when (teList == [] || last teList /= "chunked")
  92                                                   $ setStatus itr InternalServerError
  93                         else
  94                           case getHeader res "Transfer-Encoding" of
  95                             Nothing         -> return ()
  96                             Just "identity" -> return ()
  97                             _               -> setStatus itr InternalServerError
  98
  99                       when (getHeader res "Content-Type" == Nothing)
 100                                $ setRes itr (setHeader res "Content-Type" "application/octet-stream")
 101                  else
 102                    -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
 103                    do setRes itr (deleteHeader res "Transfer-Encoding")
 104                       when (reqMethod req /= HEAD)
 105                                $ setRes itr (deleteHeader res "Content-Type")
 106
 107                if fmap (map toLower) (getHeader res "Connection") == Just "close" then
 108                    writeTVar (itrWillClose itr) True
 109                  else
 110                    setRes itr (setHeader res "Connection" "close")
 111
 112                when (reqMethod req == HEAD || not canHaveBody)
 113                         $ writeTVar (itrWillDiscardBody itr) True
 114
 115       setStatus itr status
 116           = writeTVar (itrResponse itr) (Just $ Response {
 117                                                     resVersion = HttpVersion 1 1
 118                                                   , resStatus  = status
 119                                                   , resHeaders = []
 120                                                   })
 121
 122       setRes itr res
 123           = writeTVar (itrResponse itr) (Just res)
 124
 125
 126 completeUnconditionalHeaders :: Response -> IO Response
 127 completeUnconditionalHeaders res
 128     = return res >>= compServer >>= compDate >>= return
 129       where
 130         compServer res
 131             = case getHeader res "Server" of
 132                 Nothing -> return $ addHeader res "Server" "Lucu/1.0"
 133                 Just _  -> return res
 134
 135         compDate res
 136             = case getHeader res "Date" of
 137                 Nothing -> do time <- getClockTime
 138                               return $ addHeader res "Date" $ formatHTTPDateTime time
 139                 Just _  -> return res