{-# LANGUAGE
    DoAndIfThenElse
  , OverloadedStrings
  , RecordWildCards
  , UnicodeSyntax
  #-}
module Network.HTTP.Lucu.Postprocess
    ( postprocess
    )
    where
import Control.Applicative
import Control.Concurrent.STM
import Control.Monad
import Control.Monad.Unicode
import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
import qualified Data.Ascii as A
import Data.Maybe
import Data.Monoid.Unicode
import GHC.Conc (unsafeIOToSTM)
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.DefaultPage
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
import Prelude.Unicode

postprocess ∷ NormalInteraction → STM ()
postprocess ni@(NI {..})
    = do void $ tryPutTMVar niSendContinue False
         abortOnCertainConditions ni
         postprocessWithRequest ni
         completeUnconditionalHeaders ni

abortOnCertainConditions ∷ NormalInteraction → STM ()
abortOnCertainConditions (NI {..})
    = readTVar niResponse ≫= go
    where
      go ∷ Response → STM ()
      go res@(Response {..})
          = do unless (any (\ p → p resStatus) [ isSuccessful
                                               , isRedirection
                                               , isError
                                               ])
                   $ abort'
                   $ A.toAsciiBuilder "Inappropriate status code for a response: "
                   ⊕ printStatusCode resStatus

               when ( toStatusCode resStatus ≡ Just MethodNotAllowed ∧
                      hasHeader "Allow" res )
                   $ abort'
                   $ A.toAsciiBuilder "The status was "
                   ⊕ printStatusCode resStatus
                   ⊕ A.toAsciiBuilder " but no \"Allow\" header."

               when ( toStatusCode resStatus ≢ Just NotModified  ∧
                      isRedirection resStatus ∧
                      hasHeader "Location" res )
                   $ abort'
                   $ A.toAsciiBuilder "The status code was "
                   ⊕ printStatusCode resStatus
                   ⊕ A.toAsciiBuilder " but no Location header."

      abort' ∷ AsciiBuilder → STM ()
      abort' = throwSTM
               ∘ mkAbortion' InternalServerError
               ∘ A.toText
               ∘ A.fromAsciiBuilder

postprocessWithRequest ∷ NormalInteraction → STM ()
postprocessWithRequest ni@(NI {..})
    = do willDiscardBody ← readTVar niWillDiscardBody
         canHaveBody     ← if willDiscardBody then
                               return False
                           else
                               resCanHaveBody <$> readTVar niResponse

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

         if canHaveBody then
             do when niWillChunkBody $
                    writeHeader ni "Transfer-Encoding" (Just "chunked")
                writeDefaultPageIfNeeded ni
         else
             do writeTVar niWillDiscardBody True
                -- These headers make sense for HEAD requests even
                -- when there won't be a response entity body.
                when (reqMethod niRequest ≢ HEAD)
                    $ updateRes ni
                    $ deleteHeader "Content-Type"
                    ∘ deleteHeader "Etag"
                    ∘ deleteHeader "Last-Modified"

         hasConnClose ← (≡ Just "close") <$> readCIHeader ni "Connection"
         willClose    ← readTVar niWillClose
         when (hasConnClose ∧ (¬) willClose)
             $ writeTVar niWillClose True
         when ((¬) hasConnClose ∧ willClose)
             $ writeHeader ni "Connection" (Just "close")

writeDefaultPageIfNeeded ∷ NormalInteraction → STM ()
writeDefaultPageIfNeeded ni@(NI {..})
    = do resHasCType ← readTVar niResponseHasCType
         unless resHasCType
             $ do writeHeader ni "Content-Type" $ Just defaultPageContentType
                  writeHeader ni "Content-Encoding" Nothing
                  res ← readTVar niResponse
                  let body = getDefaultPage niConfig (Just niRequest) res
                  putTMVar niBodyToSend body

completeUnconditionalHeaders ∷ NormalInteraction → STM ()
completeUnconditionalHeaders ni@(NI {..})
    = do srv ← readHeader ni "Server"
         when (isNothing srv) $
             writeHeader ni "Server" $ Just $ cnfServerSoftware niConfig

         date ← readHeader ni "Date"
         when (isNothing date) $
             do date' ← unsafeIOToSTM getCurrentDate
                writeHeader ni "Date" $ Just date'

writeHeader ∷ NormalInteraction → CIAscii → Maybe Ascii → STM ()
{-# INLINE writeHeader #-}
writeHeader ni k v
    = case v of
        Just v' → updateRes ni $ setHeader    k v'
        Nothing → updateRes ni $ deleteHeader k

readHeader ∷ NormalInteraction → CIAscii → STM (Maybe Ascii)
{-# INLINE readHeader #-}
readHeader (NI {..}) k
    = getHeader k <$> readTVar niResponse

readCIHeader ∷ NormalInteraction → CIAscii → STM (Maybe CIAscii)
{-# INLINE readCIHeader #-}
readCIHeader (NI {..}) k
    = getCIHeader k <$> readTVar niResponse

updateRes ∷ NormalInteraction → (Response → Response) → STM ()
{-# INLINE updateRes #-}
updateRes (NI {..}) f
    = do old ← readTVar niResponse
         writeTVar niResponse $ f old