{-# LANGUAGE
    DoAndIfThenElse
  , OverloadedStrings
  , RecordWildCards
  , 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, AsciiBuilder)
import qualified Data.Ascii as A
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.DefaultPage
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

postprocess ∷ Interaction → STM ()
postprocess itr@(Interaction {..})
    = do abortOnCertainConditions itr

         case itrRequest of
           Just req → postprocessWithRequest itr req
           Nothing  → return ()

         updateResIO itr $ completeUnconditionalHeaders itrConfig

abortOnCertainConditions ∷ Interaction → STM ()
abortOnCertainConditions (Interaction {..})
    = readTVar itrResponse ≫= 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 ( resStatus ≡ MethodNotAllowed ∧
                      hasHeader "Allow" res        )
                   $ abort'
                   $ A.toAsciiBuilder "The status was "
                   ⊕ printStatusCode resStatus
                   ⊕ A.toAsciiBuilder " but no \"Allow\" header."

               when ( resStatus ≢ 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' = abortSTM InternalServerError []
               ∘ Just
               ∘ A.toText
               ∘ A.fromAsciiBuilder

postprocessWithRequest ∷ Interaction → Request → STM ()
postprocessWithRequest itr@(Interaction {..}) (Request {..})
    = do willDiscardBody ← readTVar itrWillDiscardBody
         canHaveBody     ← if willDiscardBody then
                               return False
                           else
                               resCanHaveBody <$> readTVar itrResponse

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

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

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

writeDefaultPageIfNeeded ∷ Interaction → STM ()
writeDefaultPageIfNeeded itr@(Interaction {..})
    = do resHasCType ← readTVar itrResponseHasCType
         unless resHasCType
             $ do writeHeader itr "Content-Type" (Just defaultPageContentType)
                  writeHeader itr "Content-Encoding" Nothing
                  res ← readTVar itrResponse
                  let page = getDefaultPage itrConfig itrRequest res
                  putTMVar itrBodyToSend page

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

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

updateRes ∷ Interaction → (Response → Response) → STM ()
{-# INLINE updateRes #-}
updateRes (Interaction {..}) f
    = do old ← readTVar itrResponse
         writeTVar itrResponse (f old)

updateResIO ∷ Interaction → (Response → IO Response) → STM ()
{-# INLINE updateResIO #-}
updateResIO (Interaction {..}) f
    = do old ← readTVar itrResponse
         new ← unsafeIOToSTM $ f old
         writeTVar itrResponse new

-- FIXME: Narrow the use of IO monad!
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