{-# LANGUAGE
    BangPatterns
  , DoAndIfThenElse
  , OverloadedStrings
  , UnicodeSyntax
  #-}
module Network.HTTP.Lucu.Postprocess
    ( postprocess
    , completeUnconditionalHeaders
    )
    where
import Control.Applicative
import Control.Concurrent.STM
import Control.Monad
import Control.Monad.Unicode
import Data.Ascii (Ascii, CIAscii)
import qualified Data.Ascii as A
import Data.Maybe
import Data.Monoid.Unicode
import Data.Time
import qualified Data.Time.HTTP as HTTP
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.Request
import Network.HTTP.Lucu.Response
import Prelude.Unicode

{-
  
  * 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
    = do reqM ← readItr itrRequest  id itr
         res  ← readItr itrResponse id itr
         let sc = resStatus res

         unless (any (\ p → p sc) [isSuccessful, isRedirection, isError])
             $ abortSTM InternalServerError []
             $ Just
             $ A.toText
             $ A.fromAsciiBuilder
             $ A.toAsciiBuilder "The status code is not good for a final status of a response: "
             ⊕ printStatusCode sc

         when (sc ≡ MethodNotAllowed ∧ getHeader "Allow" res ≡ Nothing)
             $ abortSTM InternalServerError []
             $ Just
             $ A.toText
             $ A.fromAsciiBuilder
             $ A.toAsciiBuilder "The status was "
             ⊕ printStatusCode sc
             ⊕ A.toAsciiBuilder " but no Allow header."

         when (sc ≢ NotModified ∧ isRedirection sc ∧ getHeader "Location" res ≡ Nothing)
             $ abortSTM InternalServerError []
             $ Just
             $ A.toText
             $ A.fromAsciiBuilder
             $ A.toAsciiBuilder "The status code was "
             ⊕ printStatusCode sc
             ⊕ A.toAsciiBuilder " but no Location header."

         when (reqM ≢ Nothing) relyOnRequest

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

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

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

               cType ← readHeader "Content-Type"
               when (cType ≡ Nothing)
                        $ updateRes $ setHeader "Content-Type" defaultPageContentType

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

               conn ← readHeader "Connection"
               case conn of
                 Nothing    → return ()
                 Just value → when (A.toCIAscii value ≡ "close")
                                  $ writeItr itrWillClose True itr

               willClose ← readItr itrWillClose id itr
               when willClose
                   $ updateRes $ setHeader "Connection" "close"

               when (reqMethod req ≡ HEAD ∨ not canHaveBody)
                   $ writeTVar (itrWillDiscardBody itr) True

      readHeader ∷ CIAscii → STM (Maybe Ascii)
      {-# INLINE readHeader #-}
      readHeader k = readItr itrResponse (getHeader k) itr

      updateRes ∷ (Response → Response) → STM ()
      {-# INLINE updateRes #-}
      updateRes f = updateItr itrResponse f itr

completeUnconditionalHeaders ∷ Config → Response → IO Response
completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer
      where
        compServer res'
            = case getHeader "Server" res' of
                Nothing → return $ setHeader "Server" (cnfServerSoftware conf) res'
                Just _  → return res'

        compDate res'
            = case getHeader "Date" res' of
                Nothing → do date ← getCurrentDate
                             return $ setHeader "Date" date res'
                Just _  → return res'

getCurrentDate ∷ IO Ascii
getCurrentDate = HTTP.toAscii <$> getCurrentTime