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

import           Control.Concurrent.STM
import           Control.Monad
import qualified Data.ByteString as Strict (ByteString)
import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
import           Data.IORef
import           Data.Maybe
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           System.IO.Unsafe

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

         unless (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 (C8.pack "Allow") res == Nothing)
                  $ abortSTM InternalServerError []
                        $ Just ("The status was " ++ show sc ++ " but no Allow header.")

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

         when (reqM /= Nothing) relyOnRequest

         -- itrResponse の内容は relyOnRequest によって變へられてゐる可
         -- 能性が高い。
         do oldRes <- readItr itr itrResponse id
            newRes <- unsafeIOToSTM
                      $ completeUnconditionalHeaders (itrConfig itr) oldRes
            writeItr itr itrResponse newRes
    where
      relyOnRequest :: STM ()
      relyOnRequest
          = 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 $! deleteHeader (C8.pack "Content-Length")
               updateRes $! deleteHeader (C8.pack "Transfer-Encoding")

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

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

               conn <- readHeader (C8.pack "Connection")
               case conn of
                 Nothing    -> return ()
                 Just value -> when (value `noCaseEq` C8.pack "close")
                                   $ writeItr itr itrWillClose True

               willClose <- readItr itr itrWillClose id
               when willClose
                        $ updateRes $! setHeader (C8.pack "Connection") (C8.pack "close")

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

      readHeader :: Strict.ByteString -> STM (Maybe Strict.ByteString)
      readHeader !name
          = readItr itr itrResponse $ getHeader name

      updateRes :: (Response -> Response) -> STM ()
      updateRes !updator 
          = updateItr itr itrResponse updator


completeUnconditionalHeaders :: Config -> Response -> IO Response
completeUnconditionalHeaders !conf !res
    = compServer res >>= compDate
      where
        compServer res'
            = case getHeader (C8.pack "Server") res' of
                Nothing -> return $ setHeader (C8.pack "Server") (cnfServerSoftware conf) res'
                Just _  -> return res'

        compDate res'
            = case getHeader (C8.pack "Date") res' of
                Nothing -> do date <- getCurrentDate
                              return $ setHeader (C8.pack "Date") date res'
                Just _  -> return res'


cache :: IORef (UTCTime, Strict.ByteString)
cache = unsafePerformIO $
        newIORef (UTCTime (ModifiedJulianDay 0) 0, undefined)
{-# NOINLINE cache #-}

getCurrentDate :: IO Strict.ByteString
getCurrentDate = do now                     <- getCurrentTime
                    (cachedTime, cachedStr) <- readIORef cache

                    if now `mostlyEq` cachedTime then
                        return cachedStr
                      else
                        do let dateStr = C8.pack $ HTTP.format now
                           writeIORef cache (now, dateStr)
                           return dateStr
    where
      mostlyEq :: UTCTime -> UTCTime -> Bool
      mostlyEq a b
          = (utctDay a == utctDay b)
            &&
            (fromEnum (utctDayTime a) == fromEnum (utctDayTime b))