{-# LANGUAGE
    DoAndIfThenElse
  , RecordWildCards
  , ScopedTypeVariables
  , UnicodeSyntax
  #-}
module Network.HTTP.Lucu.ResponseWriter
    ( responseWriter
    )
    where
import qualified Blaze.ByteString.Builder.HTTP as BB
import Control.Applicative
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import GHC.IO.Exception (IOException(..), IOErrorType(..))
import qualified Data.Ascii as A
import Data.Monoid.Unicode
import qualified Data.Sequence as S
import Data.Sequence (ViewR(..))
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.HandleLike
import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Response
import Prelude.Unicode
import System.IO (hPutStrLn, stderr)

data Context h
    = Context {
        cConfig ∷ !Config
      , cHandle ∷ !h
      , cQueue  ∷ !InteractionQueue
      }

responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO ()
responseWriter cnf h tQueue readerTID
    = awaitSomethingToWrite (Context cnf h tQueue)
      `catches`
      [ Handler handleIOE
      , Handler handleAsyncE
      , Handler handleOthers
      ]
      `finally`
      do killThread readerTID
         hClose h
    where
      handleIOE ∷ IOException → IO ()
      handleIOE e@(IOError {..})
          | ioe_type ≡ ResourceVanished = return ()
          | otherwise                   = dump e

      handleAsyncE ∷ AsyncException → IO ()
      handleAsyncE ThreadKilled = return ()
      handleAsyncE e            = dump e

      handleOthers ∷ SomeException → IO ()
      handleOthers = dump

      dump ∷ Exception e ⇒ e → IO ()
      dump e
          = do hPutStrLn stderr "Lucu: responseWriter caught an exception:"
               hPutStrLn stderr $ show e

awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO ()
awaitSomethingToWrite ctx@(Context {..})
    = join $
      atomically $
      do queue ← readTVar cQueue
         case S.viewr queue of
           EmptyR        → retry
           queue' :> itr → do writeTVar cQueue queue'
                              return $ writeSomething ctx itr

writeSomething ∷ HandleLike h ⇒ Context h → SomeInteraction → IO ()
writeSomething ctx itr
    = let writer = writeResponseForNI  ctx <$> fromInteraction itr <|>
                   writeResponseForSEI ctx <$> fromInteraction itr <|>
                   writeResponseForSYI ctx <$> fromInteraction itr <|>
                   endOfResponses          <$> fromInteraction itr
      in
        case writer of
          Just f  → f
          Nothing → fail "Internal error: unknown interaction type"

writeResponseForNI ∷ HandleLike h
                   ⇒ Context h
                   → NormalInteraction
                   → IO ()
writeResponseForNI = writeContinueIfNeeded

writeContinueIfNeeded ∷ HandleLike h
                      ⇒ Context h
                      → NormalInteraction
                      → IO ()
writeContinueIfNeeded ctx@(Context {..}) ni@(NI {..})
    = do isNeeded ← atomically $ readTMVar niSendContinue
         when isNeeded
             $ do let cont = Response {
                               resVersion = HttpVersion 1 1
                             , resStatus  = fromStatusCode Continue
                             , resHeaders = (∅)
                             }
                  hPutBuilder cHandle $ A.toBuilder $ printResponse cont
                  hFlush cHandle
         writeHeader ctx ni

writeHeader ∷ HandleLike h
            ⇒ Context h
            → NormalInteraction
            → IO ()
writeHeader ctx@(Context {..}) ni@(NI {..})
    = do res ← atomically $
               do state ← readTVar niState
                  if state ≥ SendingBody then
                      readTVar niResponse
                  else
                      retry -- Too early to write header fields.
         hPutBuilder cHandle $ A.toBuilder $ printResponse res
         hFlush cHandle
         writeBodyIfNeeded ctx ni

writeBodyIfNeeded ∷ HandleLike h
                  ⇒ Context h
                  → NormalInteraction
                  → IO ()
writeBodyIfNeeded ctx ni@(NI {..})
    = join $
      atomically $
      do willDiscardBody ← readTVar niWillDiscardBody
         if willDiscardBody then
             return $ discardBody ctx ni
         else
             if niWillChunkBody then
                 return $ writeChunkedBody    ctx ni
             else
                 return $ writeNonChunkedBody ctx ni

discardBody ∷ HandleLike h
            ⇒ Context h
            → NormalInteraction
            → IO ()
discardBody ctx ni@(NI {..})
    = join $
      atomically $
      do chunk ← tryTakeTMVar niBodyToSend
         case chunk of
           Just _  → return $ discardBody ctx ni
           Nothing → do state ← readTVar niState
                        if state ≡ Done then
                            return $ finalize ctx ni
                        else
                            retry

writeChunkedBody ∷ HandleLike h
                 ⇒ Context h
                 → NormalInteraction
                 → IO ()
writeChunkedBody ctx@(Context {..}) ni@(NI {..})
    = join $
      atomically $
      do chunk ← tryTakeTMVar niBodyToSend
         case chunk of
           Just b  → return $
                     do hPutBuilder cHandle $ BB.chunkedTransferEncoding b
                        hFlush cHandle
                        writeChunkedBody ctx ni
           Nothing → do state ← readTVar niState
                        if state ≡ Done then
                            return $
                            do hPutBuilder cHandle BB.chunkedTransferTerminator
                               hFlush cHandle
                               finalize ctx ni
                        else
                            retry

writeNonChunkedBody ∷ HandleLike h
                    ⇒ Context h
                    → NormalInteraction
                    → IO ()
writeNonChunkedBody ctx@(Context {..}) ni@(NI {..})
    = join $
      atomically $
      do chunk ← tryTakeTMVar niBodyToSend
         case chunk of
           Just b  → return $
                     do hPutBuilder cHandle b
                        hFlush cHandle
                        writeNonChunkedBody ctx ni
           Nothing → do state ← readTVar niState
                        if state ≡ Done then
                            return $ finalize ctx ni
                        else
                            retry

finalize ∷ HandleLike h ⇒ Context h → NormalInteraction → IO ()
finalize ctx@(Context {..}) (NI {..})
    = join $
      atomically $
      do willClose    ← readTVar  niWillClose
         sentContinue ← takeTMVar niSendContinue
         return $
             if needToClose willClose sentContinue then
                 return ()
             else
                 awaitSomethingToWrite ctx
    where
      needToClose ∷ Bool → Bool → Bool
      needToClose willClose sentContinue
          -- Explicitly instructed to close the connection.
          | willClose = True
          -- We've sent both "HTTP/1.1 100 Continue" and a final
          -- response, so nothing prevents our connection from keeping
          -- alive.
          | sentContinue = False
          -- We've got "Expect: 100-continue" but have sent a final
          -- response without sending "HTTP/1.1 100
          -- Continue". According to the RFC 2616 (HTTP/1.1), it is
          -- undecidable whether the client will send us its
          -- (rejected) request body OR start a completely new request
          -- in this situation. So the only possible thing to do is to
          -- brutally shutdown the connection.
          | niExpectedContinue = True
          -- The client didn't expect 100-continue so we haven't sent
          -- one. No need to do anything special.
          | otherwise = False

writeResponseForSEI ∷ HandleLike h
                    ⇒ Context h
                    → SemanticallyInvalidInteraction
                    → IO ()
writeResponseForSEI ctx@(Context {..}) (SEI {..})
    = do hPutBuilder cHandle $ A.toBuilder $ printResponse seiResponse
         unless seiWillDiscardBody $
             if seiWillChunkBody then
                 do hPutBuilder cHandle $ BB.chunkedTransferEncoding seiBodyToSend
                    hPutBuilder cHandle BB.chunkedTransferTerminator
             else
                 hPutBuilder cHandle seiBodyToSend
         hFlush cHandle
         if seiWillClose ∨ seiExpectedContinue then
             return ()
         else
             awaitSomethingToWrite ctx

writeResponseForSYI ∷ HandleLike h
                    ⇒ Context h
                    → SyntacticallyInvalidInteraction
                    → IO ()
writeResponseForSYI (Context {..}) (SYI {..})
    = do hPutBuilder cHandle $ A.toBuilder $ printResponse syiResponse
         hPutBuilder cHandle syiBodyToSend
         hFlush cHandle
         return ()

endOfResponses ∷ EndOfInteraction → IO ()
endOfResponses _ = return ()