{-# 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 Data.Convertible.Base
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'
                   $ cs ("Inappropriate status code for a response: " ∷ Ascii)
                   ⊕ cs resStatus

               when ( resStatus ≡ cs MethodNotAllowed ∧
                      (¬) (hasHeader "Allow" res)     )
                   $ abort'
                   $ cs ("The status was " ∷ Ascii)
                   ⊕ cs resStatus
                   ⊕ cs (" but no \"Allow\" header." ∷ Ascii)

               when ( resStatus ≢ cs NotModified     ∧
                      isRedirection resStatus        ∧
                      (¬) (hasHeader "Location" res) )
                   $ abort'
                   $ cs ("The status code was " ∷ Ascii)
                   ⊕ cs resStatus
                   ⊕ cs (" but no Location header." ∷ Ascii)

      abort' ∷ AsciiBuilder → STM ()
      abort' = throwSTM
               ∘ mkAbortion' InternalServerError
               ∘ cs

postprocessWithRequest ∷ NormalInteraction → STM ()
postprocessWithRequest ni@(NI {..})
    = do updateRes ni
             $ deleteHeader "Content-Length"
             ∘ deleteHeader "Transfer-Encoding"

         canHaveBody ← resCanHaveBody <$> readTVar niResponse
         if canHaveBody then
             do when niWillChunkBody
                    $ writeHeader ni "Transfer-Encoding" (Just "chunked")
                when (reqMethod niRequest ≢ HEAD)
                    $ writeDefaultPageIfNeeded ni
         else
             -- 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 = defaultPageForResponse 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