Network/HTTP/Lucu/Postprocess.hs

   1 module Network.HTTP.Lucu.Postprocess
   2     ( postprocess
   3     , completeUnconditionalHeaders
   4     )
   5     where
   6
   7 import           Control.Concurrent.STM
   8 import           Control.Monad
   9 import           Data.ByteString.Base (ByteString)
  10 import qualified Data.ByteString.Char8 as C8
  11 import           Data.IORef
  12 import           Data.Maybe
  13 import           GHC.Conc (unsafeIOToSTM)
  14 import           Network.HTTP.Lucu.Abortion
  15 import           Network.HTTP.Lucu.Config
  16 import           Network.HTTP.Lucu.Headers
  17 import           Network.HTTP.Lucu.HttpVersion
  18 import           Network.HTTP.Lucu.Interaction
  19 import           Network.HTTP.Lucu.RFC1123DateTime
  20 import           Network.HTTP.Lucu.Request
  21 import           Network.HTTP.Lucu.Response
  22 import           System.Time
  23 import           System.IO.Unsafe
  24
  25 {-
  26
  27   * Response が未設定なら、200 OK にする。
  28
  29   * ステータスが 2xx, 3xx, 4xx, 5xx のいずれでもなければ 500 にする。
  30
  31   * 405 Method Not Allowed なのに Allow ヘッダが無ければ 500 にする。
  32
  33   * 304 Not Modified 以外の 3xx なのに Location ヘッダが無ければ 500 に
  34     する。
  35
  36   * Content-Length があれば、それを削除する。Transfer-Encoding があって
  37     も削除する。
  38
  39   * HTTP/1.1 であり、body を持つ事が出來る時、Transfer-Encoding を
  40     chunked に設定する。
  41
  42   * body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。
  43     出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除
  44     する。
  45
  46   * body を持つ事が出來ない時、body 破棄フラグを立てる。
  47
  48   * Connection: close が設定されてゐる時、切斷フラグを立てる。
  49
  50   * 切斷フラグが立ってゐる時、Connection: close を設定する。
  51
  52   * Server が無ければ設定。
  53
  54   * Date が無ければ設定。
  55
  56 -}
  57
  58 postprocess :: Interaction -> STM ()
  59 postprocess itr
  60     = itr `seq`
  61       do reqM <- readItr itr itrRequest id
  62          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 (C8.pack "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 (C8.pack "Location") res == Nothing)
  75                   $ abortSTM InternalServerError []
  76                         $ Just ("The status code was " ++ show sc ++ " but no Location header.")
  77
  78          when (reqM /= Nothing)
  79               $ relyOnRequest itr
  80
  81          -- itrResponse の内容は relyOnRequest によって變へられてゐる可
  82          -- 能性が高い。
  83          do oldRes <- readItr itr itrResponse id
  84             newRes <- unsafeIOToSTM
  85                       $ completeUnconditionalHeaders (itrConfig itr) oldRes
  86             writeItr itr itrResponse newRes
  87     where
  88       relyOnRequest :: Interaction -> STM ()
  89       relyOnRequest itr
  90           = itr `seq`
  91             do status <- readItr itr itrResponse resStatus
  92                req    <- readItr itr itrRequest fromJust
  93
  94                let reqVer      = reqVersion req
  95                    canHaveBody = if reqMethod req == HEAD then
  96                                      False
  97                                  else
  98                                      not (isInformational status ||
  99                                           status == NoContent    ||
 100                                           status == ResetContent ||
 101                                           status == NotModified    )
 102
 103                updateRes itr $! deleteHeader (C8.pack "Content-Length")
 104                updateRes itr $! deleteHeader (C8.pack "Transfer-Encoding")
 105
 106                cType <- readHeader itr (C8.pack "Content-Type")
 107                when (cType == Nothing)
 108                         $ updateRes itr $ setHeader (C8.pack "Content-Type") defaultPageContentType
 109
 110                if canHaveBody then
 111                    when (reqVer == HttpVersion 1 1)
 112                             $ do updateRes itr $! setHeader (C8.pack "Transfer-Encoding") (C8.pack "chunked")
 113                                  writeItr itr itrWillChunkBody True
 114                  else
 115                    -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
 116                    when (reqMethod req /= HEAD)
 117                             $ do updateRes itr $! deleteHeader (C8.pack "Content-Type")
 118                                  updateRes itr $! deleteHeader (C8.pack "Etag")
 119                                  updateRes itr $! deleteHeader (C8.pack "Last-Modified")
 120
 121                conn <- readHeader itr (C8.pack "Connection")
 122                case conn of
 123                  Nothing    -> return ()
 124                  Just value -> if value `noCaseEq` C8.pack "close" then
 125                                    writeItr itr itrWillClose True
 126                                else
 127                                    return ()
 128
 129                willClose <- readItr itr itrWillClose id
 130                when willClose
 131                         $ updateRes itr $! setHeader (C8.pack "Connection") (C8.pack "close")
 132
 133                when (reqMethod req == HEAD || not canHaveBody)
 134                         $ writeTVar (itrWillDiscardBody itr) True
 135
 136       readHeader :: Interaction -> ByteString -> STM (Maybe ByteString)
 137       readHeader itr name
 138           = itr `seq` name `seq`
 139             readItr itr itrResponse $ getHeader name
 140
 141       updateRes :: Interaction -> (Response -> Response) -> STM ()
 142       updateRes itr updator
 143           = itr `seq` updator `seq`
 144             updateItr itr itrResponse updator
 145
 146
 147 completeUnconditionalHeaders :: Config -> Response -> IO Response
 148 completeUnconditionalHeaders conf res
 149     = conf `seq` res `seq`
 150       return res >>= compServer >>= compDate >>= return
 151       where
 152         compServer res
 153             = case getHeader (C8.pack "Server") res of
 154                 Nothing -> return $ setHeader (C8.pack "Server") (cnfServerSoftware conf) res
 155                 Just _  -> return res
 156
 157         compDate res
 158             = case getHeader (C8.pack "Date") res of
 159                 Nothing -> do date <- getCurrentDate
 160                               return $ setHeader (C8.pack "Date") date res
 161                 Just _  -> return res
 162
 163
 164 cache :: IORef (ClockTime, ByteString)
 165 cache = unsafePerformIO $
 166         newIORef (TOD 0 0, undefined)
 167 {-# NOINLINE cache #-}
 168
 169 getCurrentDate :: IO ByteString
 170 getCurrentDate = do now@(TOD curSec _)           <- getClockTime
 171                     (TOD cachedSec _, cachedStr) <- readIORef cache
 172
 173                     if curSec == cachedSec then
 174                         return cachedStr
 175                       else
 176                         do let dateStr = C8.pack $ formatHTTPDateTime now
 177                            writeIORef cache (now, dateStr)
 178                            return dateStr