module Network.HTTP.Lucu.ResponseWriter
    ( responseWriter
    )
    where

import qualified Data.ByteString.Lazy.Char8 as C8
import           Control.Concurrent
import           Control.Concurrent.STM
import           Control.Exception
import           Control.Monad
import qualified Data.Sequence as S
import           Data.Sequence (ViewR(..))
import           Network.HTTP.Lucu.Config
import           Network.HTTP.Lucu.Format
import           Network.HTTP.Lucu.HandleLike
import           Network.HTTP.Lucu.Headers
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 (stderr)


responseWriter :: HandleLike h => Config -> h -> InteractionQueue -> ThreadId -> IO ()
responseWriter !cnf !h !tQueue !readerTID
    = awaitSomethingToWrite
      `catches`
      [ Handler (( \ _                   -> return () ) :: IOException -> IO ())
      , Handler  ( \ ThreadKilled        -> return () )
      , Handler  ( \ BlockedIndefinitelyOnSTM -> hPutStrLn stderr "requestWriter: blocked indefinitely" )
      , Handler (( \ e                   -> hPutStrLn stderr (show e) ) :: SomeException -> IO ())
      ]
    where
      awaitSomethingToWrite :: IO ()
      awaitSomethingToWrite 
          = {-# SCC "awaitSomethingToWrite" #-}
            join $!
                 atomically $!
                 -- キューが空でなくなるまで待つ
                 do queue <- readTVar tQueue
                    -- GettingBody 状態にあり、Continue が期待されてゐ
                    -- て、それがまだ送信前なのであれば、Continue を送
                    -- 信する。
                    case S.viewr queue of
                      EmptyR   -> retry
                      _ :> itr -> do state <- readItr itr itrState id

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

      writeContinueIfNecessary :: Interaction -> STM (IO ())
      writeContinueIfNecessary !itr
          = {-# SCC "writeContinueIfNecessary" #-}
            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 であれば後処理をする。
          = {-# SCC "writeHeaderOrBodyIfNecessary" #-}
            do wroteHeader <- readItr itr itrWroteHeader id
               
               if not wroteHeader then
                   return $! writeHeader itr
                 else
                   do bodyToSend <- readItr itr itrBodyToSend id

                      if C8.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
          = {-# SCC "writeContinue" #-}
            do let cont = Response {
                            resVersion = HttpVersion 1 1
                          , resStatus  = Continue
                          , resHeaders = emptyHeaders
                          }
               cont' <- completeUnconditionalHeaders cnf cont
               hPutResponse h cont'
               hFlush h
               atomically $! writeItr itr itrWroteContinue True
               awaitSomethingToWrite

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

      finishBodyChunk :: Interaction -> IO ()
      finishBodyChunk !itr
          = {-# SCC "finishBodyChunk" #-}
            do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
               willChunkBody   <- atomically $! readItr itr itrWillChunkBody   id
               when (not willDiscardBody && willChunkBody)
                        $ hPutLBS h (C8.pack "0\r\n\r\n") >> hFlush h

      finalize :: Interaction -> IO ()
      finalize !itr
          = {-# SCC "finalize" #-}
            do finishBodyChunk itr
               willClose <- atomically $!
                            do queue <- readTVar tQueue

                               case S.viewr queue of
                                 EmptyR         -> return () -- this should never happen
                                 remaining :> _ -> writeTVar tQueue remaining

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