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  ( \ BlockedIndefinitely -> hPutStrLn stderr "requestWriter: blocked indefinitely" )
      , Handler (( \ e                   -> hPutStrLn stderr (show e) ) :: SomeException -> IO ())
      ]
    where
      awaitSomethingToWrite :: IO ()
      awaitSomethingToWrite 
          = {-# SCC "awaitSomethingToWrite" #-}
            do action
                   <- 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
               action

      writeContinueIfNecessary :: Interaction -> STM (IO ())
      writeContinueIfNecessary itr
          = {-# SCC "writeContinueIfNecessary" #-}
            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 であれば後処理をする。
          = {-# SCC "writeHeaderOrBodyIfNecessary" #-}
            itr `seq`
            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" #-}
            itr `seq`
            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" #-}
            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
          = {-# SCC "writeBodyChunk" #-}
            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 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" #-}
            itr `seq`
            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" #-}
            itr `seq`
            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