module Network.HTTP.Lucu.ResponseWriter
    ( responseWriter -- Config -> Handle -> InteractionQueue -> IO ()
    )
    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.HttpVersion
import           Network.HTTP.Lucu.Interaction
import           Network.HTTP.Lucu.Postprocess
import           Network.HTTP.Lucu.Response
import           Prelude hiding (catch)
import           System.IO
import           Text.Printf

import Control.Concurrent
import Debug.Trace


responseWriter :: Config -> Handle -> InteractionQueue -> ThreadId -> IO ()
responseWriter cnf h tQueue readerTID
    = 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
                         let _ :> itr = S.viewr queue
                            
                         -- GettingBody 状態にあり、Continue が期待され
                         -- てゐて、それがまだ送信前なのであれば、
                         -- Continue を送信する。
                         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
          = 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 であれば後処理をする。
          = 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
          = 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
          = do res <- atomically $ do writeItr itr itrWroteHeader True
                                      readItr itr itrResponse id
               hPutResponse h (fromJust res)
               hFlush h
               awaitSomethingToWrite
      
      writeBodyChunk :: Interaction -> IO ()
      writeBodyChunk itr
          = 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 hPrintf h "%x\r\n" (toInteger $ B.length chunk)
                                      B.hPut  h chunk
                                      hPutStr h "\r\n"
                                 else
                                   B.hPut h chunk
                               hFlush h
               awaitSomethingToWrite

      finishBodyChunk :: Interaction -> IO ()
      finishBodyChunk itr
          = 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
          = do finishBodyChunk itr
               willClose <- atomically $ do queue <- readTVar tQueue

                                            let (remaining :> _) = S.viewr queue
                                            writeTVar tQueue remaining

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