{-# LANGUAGE
    DoAndIfThenElse
  , RecordWildCards
  , ScopedTypeVariables
  , UnicodeSyntax
  #-}
module Network.HTTP.Lucu.ResponseWriter
    ( responseWriter
    )
    where
import qualified Blaze.ByteString.Builder.HTTP as BB
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
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.Postprocess
import Network.HTTP.Lucu.Response
import Prelude.Unicode
import System.IO (hPutStrLn, stderr)
import System.IO.Error

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

responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO ()
responseWriter cnf h tQueue readerTID
    = awaitSomethingToWrite (Context cnf h tQueue readerTID)
      `catches`
      [ Handler handleIOE
      , Handler handleAsyncE
      , Handler handleBIOS
      , Handler handleOthers
      ]
    where
      handleIOE ∷ IOException → IO ()
      handleIOE e
          | isIllegalOperation e
              = return () -- EPIPE: should be ignored at all.
          | otherwise
              = terminate e

      handleAsyncE ∷ AsyncException → IO ()
      handleAsyncE ThreadKilled = terminate'
      handleAsyncE e            = terminate e

      handleBIOS ∷ BlockedIndefinitelyOnSTM → IO ()
      handleBIOS = terminate

      handleOthers ∷ SomeException → IO ()
      handleOthers = terminate

      terminate ∷ Exception e ⇒ e → IO ()
      terminate e
          = do hPutStrLn stderr "requestWriter caught an exception:"
               hPutStrLn stderr (show $ toException e)
               terminate'

      terminate' ∷ IO ()
      terminate' = hClose h

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 $ writeContinueIfNeeded ctx itr

writeContinueIfNeeded ∷ HandleLike h
                      ⇒ Context h
                      → Interaction
                      → IO ()
writeContinueIfNeeded ctx@(Context {..}) itr@(Interaction {..})
    = do isNeeded ← atomically $ readTMVar itrSendContinue
         when isNeeded
             $ do let cont = Response {
                               resVersion = HttpVersion 1 1
                             , resStatus  = Continue
                             , resHeaders = (∅)
                             }
                  cont' ← completeUnconditionalHeaders cConfig cont
                  hPutBuilder cHandle $ A.toBuilder $ printResponse cont'
                  hFlush cHandle
         writeHeader ctx itr

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

writeBodyIfNeeded ∷ HandleLike h
                  ⇒ Context h
                  → Interaction
                  → IO ()
writeBodyIfNeeded ctx itr@(Interaction {..})
    = join $
      atomically $
      do willDiscardBody ← readTVar itrWillDiscardBody
         if willDiscardBody then
             return $ discardBody ctx itr
         else
             do willChunkBody ← readTVar itrWillChunkBody
                if willChunkBody then
                    return $ writeChunkedBody ctx itr
                else
                    return $ writeNonChunkedBody ctx itr

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

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

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

finalize ∷ HandleLike h ⇒ Context h → Interaction → IO ()
finalize ctx@(Context {..}) (Interaction {..})
    = join $
      atomically $
      do sentContinue    ← takeTMVar itrSendContinue
         willDiscardBody ← readTVar  itrWillDiscardBody
         willChunkBody   ← readTVar  itrWillChunkBody
         willClose       ← readTVar  itrWillClose
         queue           ← readTVar  cQueue
         case S.viewr queue of
           queue' :> _
               → writeTVar cQueue queue'
           EmptyR
               → fail "finalize: cQueue is empty, which should never happen."
         return $
             do when (((¬) willDiscardBody) ∧ willChunkBody)
                    $ do hPutBuilder cHandle BB.chunkedTransferTerminator
                         hFlush cHandle
                if willClose ∨ needToClose sentContinue then
                    -- The RequestReader is probably blocking on
                    -- hWaitForInput so we have to kill it before
                    -- closing the socket.
                    -- THINKME: Couldn't that somehow be avoided?
                    do killThread cReader
                       hClose cHandle
                else
                    awaitSomethingToWrite ctx
    where
      needToClose ∷ Bool → Bool
      needToClose sentContinue
          -- 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.
          | itrExpectedContinue ≡ Just True = True
          -- The client didn't expect 100-continue so we haven't sent
          -- one. No need to do anything special.
          | otherwise = False