module Network.HTTP.Lucu.ResponseWriter
    ( responseWriter -- 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.Interaction
import           Network.HTTP.Lucu.Response
import           Prelude hiding (catch)
import           System.IO

import Debug.Trace


responseWriter :: Handle -> InteractionQueue -> IO ()
responseWriter h tQueue
    = catch awaitSomethingToWrite $ \ exc
    -> case exc of
         IOException _ -> return ()
         _             -> 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 <- readTVar (itrState itr)

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

      writeContinueIfNecessary :: Interaction -> STM (IO ())
      writeContinueIfNecessary itr
          = do expectedContinue <- readTVar (itrExpectedContinue itr)
               if expectedContinue then

                   do wroteContinue <- readTVar $ itrWroteContinue itr
                      if wroteContinue then
                          -- 既に Continue を書込み濟
                          retry
                        else
                          return $ writeContinue itr
                 else
                   retry

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

                      if B.null bodyToSend then
                          do state <- readTVar (itrState itr)

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

      writeContinue :: Interaction -> IO ()
      writeContinue itr = fail "FIXME: not implemented"

      writeHeader :: Interaction -> IO ()
      writeHeader itr
          = do res <- atomically $ do writeTVar (itrWroteHeader itr) True
                                      readTVar  (itrResponse    itr)
               hPutResponse h (fromJust res)
               hFlush h
               awaitSomethingToWrite
      
      writeBodyChunk :: Interaction -> IO ()
      writeBodyChunk itr = fail "FIXME: not implemented"

      finishBodyChunk :: Interaction -> IO ()
      finishBodyChunk itr = return () -- FIXME: not implemented

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

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

                                            readTVar $ itrWillClose itr
               if willClose then
                   hClose h
                 else
                   awaitSomethingToWrite