-- #hide
module Network.HTTP.Lucu.ResponseWriter
    ( responseWriter
    )
    where

import qualified Data.ByteString.Lazy.Char8 as B
import           Data.ByteString.Lazy.Char8 (ByteString)
import           Control.Concurrent.STM
import           Control.Exception
import           Control.Monad
import           Data.Maybe
import qualified Data.Sequence as S
import           Data.Sequence (Seq, ViewR(..))
import           Network.HTTP.Lucu.Config
import           Network.HTTP.Lucu.Format
import           Network.HTTP.Lucu.HttpVersion
import           Network.HTTP.Lucu.Interaction
import           Network.HTTP.Lucu.Postprocess
import           Network.HTTP.Lucu.Response
import           Prelude hiding (catch)
import           System.IO

import Control.Concurrent
import Debug.Trace
import GHC.Conc (unsafeIOToSTM)


responseWriter :: Config -> Handle -> InteractionQueue -> ThreadId -> IO ()
responseWriter cnf h tQueue readerTID
    = cnf `seq` h `seq` tQueue `seq` readerTID `seq`
      catch awaitSomethingToWrite $ \ exc ->
      case exc of
        IOException _               -> return ()
        AsyncException ThreadKilled -> return ()
        BlockedIndefinitely         -> putStrLn "requestWriter: blocked indefinitely"
        _                           -> print exc
    where
      awaitSomethingToWrite :: IO ()
      awaitSomethingToWrite 
          = do action
                   <- atomically $!
                      do -- キューが空でなくなるまで待つ
                         queue <- readTVar tQueue
                         when (S.null queue)
                              retry

                         -- GettingBody 状態にあり、Continue が期待され
                         -- てゐて、それがまだ送信前なのであれば、
                         -- Continue を送信する。
                         case S.viewr queue of
                           _ :> itr -> do state <- readItr itr itrState id

                                          if state == GettingBody then
                                              writeContinueIfNecessary itr
                                            else
                                              if state >= DecidingBody then
                                                  writeHeaderOrBodyIfNecessary itr
                                              else
                                                  retry
               action

      writeContinueIfNecessary :: Interaction -> STM (IO ())
      writeContinueIfNecessary itr
          = itr `seq`
            do expectedContinue <- readItr itr itrExpectedContinue id
               if expectedContinue then
                   do wroteContinue <- readItr itr itrWroteContinue id
                      if wroteContinue then
                          -- 既に Continue を書込み濟
                          retry
                        else
                          do reqBodyWanted <- readItr itr itrReqBodyWanted id
                             if reqBodyWanted /= Nothing then
                                 return $ writeContinue itr
                               else
                                 retry
                 else
                   retry

      writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ())
      writeHeaderOrBodyIfNecessary itr
          -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ
          -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が
          -- 空でなければ、それを出力する。空である時は、もし状態が
          -- Done であれば後処理をする。
          = itr `seq`
            do wroteHeader <- readItr itr itrWroteHeader id
               
               if not wroteHeader then
                   return $ writeHeader itr
                 else
                   do bodyToSend <- readItr itr itrBodyToSend id

                      if B.null bodyToSend then
                          do state <- readItr itr itrState id

                             if state == Done then
                                 return $! finalize itr
                               else
                                 retry
                        else
                          return $! writeBodyChunk itr

      writeContinue :: Interaction -> IO ()
      writeContinue itr
          = itr `seq`
            do let cont = Response {
                            resVersion = HttpVersion 1 1
                          , resStatus  = Continue
                          , resHeaders = []
                          }
               cont' <- completeUnconditionalHeaders cnf cont
               hPutResponse h cont'
               hFlush h
               atomically $! writeItr itr itrWroteContinue True
               awaitSomethingToWrite

      writeHeader :: Interaction -> IO ()
      writeHeader itr
          = itr `seq`
            do res <- atomically $! do writeItr itr itrWroteHeader True
                                       readItr itr itrResponse id
               hPutResponse h res
               hFlush h
               awaitSomethingToWrite
      
      writeBodyChunk :: Interaction -> IO ()
      writeBodyChunk itr
          = itr `seq`
            do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
               willChunkBody   <- atomically $! readItr itr itrWillChunkBody   id
               chunk           <- atomically $! do chunk <- readItr itr itrBodyToSend id
                                                   writeItr itr itrBodyToSend B.empty
                                                   return chunk
               unless willDiscardBody
                          $ do if willChunkBody then
                                   do hPutStr h (fmtHex False 0 $! fromIntegral $! B.length chunk)
                                      hPutStr h "\r\n"
                                      B.hPut  h chunk
                                      hPutStr h "\r\n"
                                 else
                                   B.hPut h chunk
                               hFlush h
               awaitSomethingToWrite

      finishBodyChunk :: Interaction -> IO ()
      finishBodyChunk itr
          = itr `seq`
            do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
               willChunkBody   <- atomically $! readItr itr itrWillChunkBody   id
               when (not willDiscardBody && willChunkBody)
                        $ hPutStr h "0\r\n\r\n" >> hFlush h

      finalize :: Interaction -> IO ()
      finalize itr
          = itr `seq`
            do finishBodyChunk itr
               willClose <- atomically $!
                            do queue <- readTVar tQueue

                               case S.viewr queue of
                                 remaining :> _ -> writeTVar tQueue remaining

                               readItr itr itrWillClose id
               if willClose then
                   -- reader は恐らく hWaitForInput してゐる最中なので、
                   -- スレッドを豫め殺して置かないとをかしくなる。
                   do killThread readerTID
                      hClose h
                 else
                   awaitSomethingToWrite