module Network.HTTP.Lucu.Postprocess
    ( postprocess -- Interaction -> STM ()
    , completeUnconditionalHeaders -- Config -> Response -> IO Response
    )
    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           Network.HTTP.Lucu.Utils
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 があれば、それを削除する。

  * HTTP/1.1 であり、且つ body を持つ事が出來る時、Transfer-Encoding の
    最後の要素が chunked でなければ 500 Internal Error にする。
    Transfer-Encoding が未設定であれば、chunked に設定する。

  * HTTP/1.0 なのに Transfer-Encoding が設定濟なら 500 Internal Server
    Error にする。但し identity だけは許す。

  * body を持つ事が出來る時、Content-Type が無ければ
    application/octet-stream にする。出來ない時、HEAD でなければ
    Content-Type, Etag, Last-Modified を削除する。

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

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

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

  * Server が無ければ設定。

  * Date が無ければ設定。

-}

postprocess :: Interaction -> STM ()
postprocess itr
    = do resM <- readItr itr itrResponse id

         case resM of
           Nothing  -> writeItr itr itrResponse
                       $ Just $ Response {
                               resVersion = HttpVersion 1 1
                             , resStatus  = Ok
                             , resHeaders = []
                             }
           Just res -> do 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 (itrRequest itr /= Nothing)
              $ relyOnRequest itr

         do oldRes <- readItr itr itrResponse id
            newRes <- unsafeIOToSTM
                      $ completeUnconditionalHeaders (itrConfig itr) (fromJust oldRes)
            writeItr itr itrResponse $ Just newRes
    where
      relyOnRequest :: Interaction -> STM ()
      relyOnRequest itr
          = do status <- readItr itr itrResponse (resStatus . fromJust)

               let req         = fromJust $ itrRequest itr
                   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"

               cType <- readHeader itr "Content-Type"
               when (cType == Nothing)
                        $ updateRes itr $ setHeader "Content-Type" "application/octet-stream"

               if canHaveBody then
                   do teM <- readHeader itr "Transfer-Encoding"
                      if reqVer == HttpVersion 1 1 then

                          do case teM of
                               Nothing -> updateRes itr $ setHeader "Transfer-Encoding" "chunked"
                               Just te -> let teList = [trim isWhiteSpace x
                                                            | x <- splitBy (== ',') (map toLower te)]
                                          in
                                            when (teList == [] || last teList /= "chunked")
                                                     $ abortSTM InternalServerError []
                                                           $ Just ("Transfer-Encoding must end with `chunked' "
                                                                   ++ "because this is an HTTP/1.1 request: "
                                                                   ++ te)

                             writeItr itr itrWillChunkBody True
                        else
                          case fmap (map toLower) teM of
                            Nothing         -> return ()
                            Just "identity" -> return ()
                            Just te         -> abortSTM InternalServerError []
                                               $ Just ("Transfer-Encoding must be `identity' because "
                                                       ++ "this is an HTTP/1.0 request: "
                                                       ++ te)
                 else
                   -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
                   do updateRes itr $ deleteHeader "Transfer-Encoding"
                      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
          = do valueMM <- readItrF itr itrResponse $ getHeader name
               case valueMM of
                 Just (Just val) -> return $ Just val
                 _               -> return Nothing

      updateRes :: Interaction -> (Response -> Response) -> STM ()
      updateRes itr updator 
          = updateItrF itr itrResponse updator


completeUnconditionalHeaders :: Config -> Response -> IO Response
completeUnconditionalHeaders conf res
    = 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