Network/HTTP/Lucu/Postprocess.hs

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