-- #hide
module Network.HTTP.Lucu.Postprocess
    ( postprocess
    , completeUnconditionalHeaders
    )
    where

import           Control.Concurrent.STM
import           Control.Monad
import           Data.Char
import           Data.Maybe
import           GHC.Conc (unsafeIOToSTM)
import           Network.HTTP.Lucu.Abortion
import           Network.HTTP.Lucu.Config
import           Network.HTTP.Lucu.Headers
import           Network.HTTP.Lucu.HttpVersion
import           Network.HTTP.Lucu.Interaction
import           Network.HTTP.Lucu.RFC1123DateTime
import           Network.HTTP.Lucu.Request
import           Network.HTTP.Lucu.Response
import           System.Time

{-
  
  * Response が未設定なら、200 OK にする。

  * ステータスが 2xx, 3xx, 4xx, 5xx のいずれでもなければ 500 にする。

  * 405 Method Not Allowed なのに Allow ヘッダが無ければ 500 にする。

  * 304 Not Modified 以外の 3xx なのに Location ヘッダが無ければ 500 に
    する。

  * Content-Length があれば、それを削除する。Transfer-Encoding があって
    も削除する。

  * HTTP/1.1 であり、body を持つ事が出來る時、Transfer-Encoding を
    chunked に設定する。

  * body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。
    出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除
    する。

  * body を持つ事が出來ない時、body 破棄フラグを立てる。

  * Connection: close が設定されてゐる時、切斷フラグを立てる。

  * 切斷フラグが立ってゐる時、Connection: close を設定する。

  * Server が無ければ設定。

  * Date が無ければ設定。

-}

postprocess :: Interaction -> STM ()
postprocess itr
    = itr `seq`
      do reqM <- readItr itr itrRequest id
         res  <- readItr itr itrResponse id
         let sc = resStatus res

         when (not $ any (\ p -> p sc) [isSuccessful, isRedirection, isError])
                  $ abortSTM InternalServerError []
                        $ Just ("The status code is not good for a final status: "
                                ++ show sc)

         when (sc == MethodNotAllowed && getHeader "Allow" res == Nothing)
                  $ abortSTM InternalServerError []
                        $ Just ("The status was " ++ show sc ++ " but no Allow header.")

         when (sc /= NotModified && isRedirection sc && getHeader "Location" res == Nothing)
                  $ abortSTM InternalServerError []
                        $ Just ("The status code was " ++ show sc ++ " but no Location header.")

         when (reqM /= Nothing)
              $ relyOnRequest itr

         -- itrResponse の内容は relyOnRequest によって變へられてゐる可
         -- 能性が高い。
         do oldRes <- readItr itr itrResponse id
            newRes <- unsafeIOToSTM
                      $ completeUnconditionalHeaders (itrConfig itr) oldRes
            writeItr itr itrResponse newRes
    where
      relyOnRequest :: Interaction -> STM ()
      relyOnRequest itr
          = itr `seq`
            do status <- readItr itr itrResponse resStatus
               req    <- readItr itr itrRequest fromJust

               let reqVer      = reqVersion req
                   canHaveBody = if reqMethod req == HEAD then
                                     False
                                 else
                                     not (isInformational status ||
                                          status == NoContent    ||
                                          status == ResetContent ||
                                          status == NotModified    )

               updateRes itr $! deleteHeader "Content-Length"
               updateRes itr $! deleteHeader "Transfer-Encoding"

               cType <- readHeader itr "Content-Type"
               when (cType == Nothing)
                        $ updateRes itr $ setHeader "Content-Type" defaultPageContentType

               if canHaveBody then
                   when (reqVer == HttpVersion 1 1)
                            $ do updateRes itr $! setHeader "Transfer-Encoding" "chunked"
                                 writeItr itr itrWillChunkBody True
                 else
                   -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
                   when (reqMethod req /= HEAD)
                            $ do updateRes itr $! deleteHeader "Content-Type"
                                 updateRes itr $! deleteHeader "Etag"
                                 updateRes itr $! deleteHeader "Last-Modified"

               conn <- readHeader itr "Connection"
               case fmap (map toLower) conn of
                 Just "close" -> writeItr itr itrWillClose True
                 _            -> return ()

               willClose <- readItr itr itrWillClose id
               when willClose
                        $ updateRes itr $! setHeader "Connection" "close"

               when (reqMethod req == HEAD || not canHaveBody)
                        $ writeTVar (itrWillDiscardBody itr) True

      readHeader :: Interaction -> String -> STM (Maybe String)
      readHeader itr name
          = itr `seq` name `seq`
            readItr itr itrResponse $ getHeader name

      updateRes :: Interaction -> (Response -> Response) -> STM ()
      updateRes itr updator 
          = itr `seq` updator `seq`
            updateItr itr itrResponse updator


completeUnconditionalHeaders :: Config -> Response -> IO Response
completeUnconditionalHeaders conf res
    = conf `seq` res `seq`
      return res >>= compServer >>= compDate >>= return
      where
        compServer res
            = case getHeader "Server" res of
                Nothing -> return $ addHeader "Server" (cnfServerSoftware conf) res
                Just _  -> return res

        compDate res
            = case getHeader "Date" res of
                Nothing -> do time <- getClockTime
                              return $ addHeader "Date" (formatHTTPDateTime time) res
                Just _  -> return res