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     = do reqM <- readItr itr itrRequest id
  61          res  <- readItr itr itrResponse id
  62          let sc = resStatus res
  63
  64          unless (any (\ p -> p sc) [isSuccessful, isRedirection, isError])
  65                   $ abortSTM InternalServerError []
  66                         $ Just ("The status code is not good for a final status: "
  67                                 ++ show sc)
  68
  69          when (sc == MethodNotAllowed && getHeader (C8.pack "Allow") res == Nothing)
  70                   $ abortSTM InternalServerError []
  71                         $ Just ("The status was " ++ show sc ++ " but no Allow header.")
  72
  73          when (sc /= NotModified && isRedirection sc && getHeader (C8.pack "Location") res == Nothing)
  74                   $ abortSTM InternalServerError []
  75                         $ Just ("The status code was " ++ show sc ++ " but no Location header.")
  76
  77          when (reqM /= Nothing) relyOnRequest
  78
  79          -- itrResponse の内容は relyOnRequest によって變へられてゐる可
  80          -- 能性が高い。
  81          do oldRes <- readItr itr itrResponse id
  82             newRes <- unsafeIOToSTM
  83                       $ completeUnconditionalHeaders (itrConfig itr) oldRes
  84             writeItr itr itrResponse newRes
  85     where
  86       relyOnRequest :: STM ()
  87       relyOnRequest
  88           = do status <- readItr itr itrResponse resStatus
  89                req    <- readItr itr itrRequest fromJust
  90
  91                let reqVer      = reqVersion req
  92                    canHaveBody = if reqMethod req == HEAD then
  93                                      False
  94                                  else
  95                                      not (isInformational status ||
  96                                           status == NoContent    ||
  97                                           status == ResetContent ||
  98                                           status == NotModified    )
  99
 100                updateRes $! deleteHeader (C8.pack "Content-Length")
 101                updateRes $! deleteHeader (C8.pack "Transfer-Encoding")
 102
 103                cType <- readHeader (C8.pack "Content-Type")
 104                when (cType == Nothing)
 105                         $ updateRes $ setHeader (C8.pack "Content-Type") defaultPageContentType
 106
 107                if canHaveBody then
 108                    when (reqVer == HttpVersion 1 1)
 109                             $ do updateRes $! setHeader (C8.pack "Transfer-Encoding") (C8.pack "chunked")
 110                                  writeItr itr itrWillChunkBody True
 111                  else
 112                    -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
 113                    when (reqMethod req /= HEAD)
 114                             $ do updateRes $! deleteHeader (C8.pack "Content-Type")
 115                                  updateRes $! deleteHeader (C8.pack "Etag")
 116                                  updateRes $! deleteHeader (C8.pack "Last-Modified")
 117
 118                conn <- readHeader (C8.pack "Connection")
 119                case conn of
 120                  Nothing    -> return ()
 121                  Just value -> when (value `noCaseEq` C8.pack "close")
 122                                    $ writeItr itr itrWillClose True
 123
 124                willClose <- readItr itr itrWillClose id
 125                when willClose
 126                         $ updateRes $! setHeader (C8.pack "Connection") (C8.pack "close")
 127
 128                when (reqMethod req == HEAD || not canHaveBody)
 129                         $ writeTVar (itrWillDiscardBody itr) True
 130
 131       readHeader :: Strict.ByteString -> STM (Maybe Strict.ByteString)
 132       readHeader !name
 133           = readItr itr itrResponse $ getHeader name
 134
 135       updateRes :: (Response -> Response) -> STM ()
 136       updateRes !updator
 137           = updateItr itr itrResponse updator
 138
 139
 140 completeUnconditionalHeaders :: Config -> Response -> IO Response
 141 completeUnconditionalHeaders !conf !res
 142     = compServer res >>= compDate
 143       where
 144         compServer res'
 145             = case getHeader (C8.pack "Server") res' of
 146                 Nothing -> return $ setHeader (C8.pack "Server") (cnfServerSoftware conf) res'
 147                 Just _  -> return res'
 148
 149         compDate res'
 150             = case getHeader (C8.pack "Date") res' of
 151                 Nothing -> do date <- getCurrentDate
 152                               return $ setHeader (C8.pack "Date") date res'
 153                 Just _  -> return res'
 154
 155
 156 cache :: IORef (UTCTime, Strict.ByteString)
 157 cache = unsafePerformIO $
 158         newIORef (UTCTime (ModifiedJulianDay 0) 0, undefined)
 159 {-# NOINLINE cache #-}
 160
 161 getCurrentDate :: IO Strict.ByteString
 162 getCurrentDate = do now                     <- getCurrentTime
 163                     (cachedTime, cachedStr) <- readIORef cache
 164
 165                     if now `mostlyEq` cachedTime then
 166                         return cachedStr
 167                       else
 168                         do let dateStr = C8.pack $ formatHTTPDateTime now
 169                            writeIORef cache (now, dateStr)
 170                            return dateStr
 171     where
 172       mostlyEq :: UTCTime -> UTCTime -> Bool
 173       mostlyEq a b
 174           = (utctDay a == utctDay b)
 175             &&
 176             (fromEnum (utctDayTime a) == fromEnum (utctDayTime b))