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 qualified Data.ByteString as Strict (ByteString)
  10 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
  11 import           Data.IORef
  12 import           Data.Maybe
  13 import           Data.Time
  14 import           GHC.Conc (unsafeIOToSTM)
  15 import           Network.HTTP.Lucu.Abortion
  16 import           Network.HTTP.Lucu.Config
  17 import           Network.HTTP.Lucu.Headers
  18 import           Network.HTTP.Lucu.HttpVersion
  19 import           Network.HTTP.Lucu.Interaction
  20 import           Network.HTTP.Lucu.RFC1123DateTime
  21 import           Network.HTTP.Lucu.Request
  22 import           Network.HTTP.Lucu.Response
  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) relyOnRequest
  79
  80          -- itrResponse の内容は relyOnRequest によって變へられてゐる可
  81          -- 能性が高い。
  82          do oldRes <- readItr itr itrResponse id
  83             newRes <- unsafeIOToSTM
  84                       $ completeUnconditionalHeaders (itrConfig itr) oldRes
  85             writeItr itr itrResponse newRes
  86     where
  87       relyOnRequest :: STM ()
  88       relyOnRequest
  89           = do status <- readItr itr itrResponse resStatus
  90                req    <- readItr itr itrRequest fromJust
  91
  92                let reqVer      = reqVersion req
  93                    canHaveBody = if reqMethod req == HEAD then
  94                                      False
  95                                  else
  96                                      not (isInformational status ||
  97                                           status == NoContent    ||
  98                                           status == ResetContent ||
  99                                           status == NotModified    )
 100
 101                updateRes $! deleteHeader (C8.pack "Content-Length")
 102                updateRes $! deleteHeader (C8.pack "Transfer-Encoding")
 103
 104                cType <- readHeader (C8.pack "Content-Type")
 105                when (cType == Nothing)
 106                         $ updateRes $ setHeader (C8.pack "Content-Type") defaultPageContentType
 107
 108                if canHaveBody then
 109                    when (reqVer == HttpVersion 1 1)
 110                             $ do updateRes $! setHeader (C8.pack "Transfer-Encoding") (C8.pack "chunked")
 111                                  writeItr itr itrWillChunkBody True
 112                  else
 113                    -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
 114                    when (reqMethod req /= HEAD)
 115                             $ do updateRes $! deleteHeader (C8.pack "Content-Type")
 116                                  updateRes $! deleteHeader (C8.pack "Etag")
 117                                  updateRes $! deleteHeader (C8.pack "Last-Modified")
 118
 119                conn <- readHeader (C8.pack "Connection")
 120                case conn of
 121                  Nothing    -> return ()
 122                  Just value -> if value `noCaseEq` C8.pack "close" then
 123                                    writeItr itr itrWillClose True
 124                                else
 125                                    return ()
 126
 127                willClose <- readItr itr itrWillClose id
 128                when willClose
 129                         $ updateRes $! setHeader (C8.pack "Connection") (C8.pack "close")
 130
 131                when (reqMethod req == HEAD || not canHaveBody)
 132                         $ writeTVar (itrWillDiscardBody itr) True
 133
 134       readHeader :: Strict.ByteString -> STM (Maybe Strict.ByteString)
 135       readHeader name
 136           = name `seq`
 137             readItr itr itrResponse $ getHeader name
 138
 139       updateRes :: (Response -> Response) -> STM ()
 140       updateRes updator
 141           = updator `seq`
 142             updateItr itr itrResponse updator
 143
 144
 145 completeUnconditionalHeaders :: Config -> Response -> IO Response
 146 completeUnconditionalHeaders conf res
 147     = conf `seq` res `seq`
 148       return res >>= compServer >>= compDate >>= return
 149       where
 150         compServer res'
 151             = case getHeader (C8.pack "Server") res' of
 152                 Nothing -> return $ setHeader (C8.pack "Server") (cnfServerSoftware conf) res'
 153                 Just _  -> return res'
 154
 155         compDate res'
 156             = case getHeader (C8.pack "Date") res' of
 157                 Nothing -> do date <- getCurrentDate
 158                               return $ setHeader (C8.pack "Date") date res'
 159                 Just _  -> return res'
 160
 161
 162 cache :: IORef (UTCTime, Strict.ByteString)
 163 cache = unsafePerformIO $
 164         newIORef (UTCTime (ModifiedJulianDay 0) 0, undefined)
 165 {-# NOINLINE cache #-}
 166
 167 getCurrentDate :: IO Strict.ByteString
 168 getCurrentDate = do now                     <- getCurrentTime
 169                     (cachedTime, cachedStr) <- readIORef cache
 170
 171                     if now `mostlyEq` cachedTime then
 172                         return cachedStr
 173                       else
 174                         do let dateStr = C8.pack $ formatHTTPDateTime now
 175                            writeIORef cache (now, dateStr)
 176                            return dateStr
 177     where
 178       mostlyEq :: UTCTime -> UTCTime -> Bool
 179       mostlyEq a b
 180           = if utctDay a == utctDay b then
 181                 fromEnum (utctDayTime a) == fromEnum (utctDayTime b)
 182             else
 183                 False