{-# LANGUAGE
    DoAndIfThenElse
  , RecordWildCards
  , ScopedTypeVariables
  , UnicodeSyntax
  #-}
module Network.HTTP.Lucu.ResponseWriter
    ( responseWriter
    )
    where
import qualified Blaze.ByteString.Builder.HTTP as BB
import qualified Data.Ascii as A
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import Data.Monoid.Unicode
import qualified Data.Sequence as S
import Data.Sequence (ViewR(..))
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.HandleLike
import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Postprocess
import Network.HTTP.Lucu.Response
import Prelude.Unicode
import System.IO (hPutStrLn, stderr)

data Context h
    = Context {
        cConfig ∷ !Config
      , cHandle ∷ !h
      , cQueue  ∷ !InteractionQueue
      , cReader ∷ !ThreadId
      }

responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO ()
responseWriter cnf h tQueue readerTID
    = awaitSomethingToWrite (Context cnf h tQueue readerTID)
      `catches`
      [ Handler $ \ (_ ∷ IOException)        → return ()
      , Handler $ \ e → case e of
                           ThreadKilled      → return ()
                           _                 → hPutStrLn stderr (show e)
      , Handler $ \ BlockedIndefinitelyOnSTM → hPutStrLn stderr "requestWriter: blocked indefinitely"
      , Handler $ \ (e ∷ SomeException)      → hPutStrLn stderr (show e)
      ]

awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO ()
awaitSomethingToWrite ctx@(Context {..})
    = join $
      atomically $
      -- キューが空でなくなるまで待つ
      do queue ← readTVar cQueue
         -- GettingBody 状態にあり、Continue が期待されてゐて、それがま
         -- だ送信前なのであれば、Continue を送信する。
         case S.viewr queue of
           EmptyR   → retry
           _ :> itr → do state ← readTVar $ itrState itr
                         if state ≡ GettingBody then
                             writeContinueIfNeeded ctx itr
                         else
                             if state ≥ DecidingBody then
                                 writeHeaderOrBodyIfNeeded ctx itr
                             else
                                 retry

writeContinueIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ())
writeContinueIfNeeded ctx itr@(Interaction {..})
    = do expectedContinue ← readTVar itrExpectedContinue
         if expectedContinue then
             do wroteContinue ← readTVar itrWroteContinue
                if wroteContinue then
                    -- 既に Continue を書込み濟
                    retry
                else
                    do reqBodyWanted ← readTVar itrReqBodyWanted
                       if reqBodyWanted ≢ Nothing then
                           return $ writeContinue ctx itr
                       else
                           retry
         else
             retry

-- DecidingBody 以降の状態にあり、まだヘッダを出力する前であれば、ヘッ
-- ダを出力する。ヘッダ出力後であり、bodyToSend が空でなければ、それを
-- 出力する。空である時は、もし状態がDone であれば後処理をする。
writeHeaderOrBodyIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ())
writeHeaderOrBodyIfNeeded ctx itr@(Interaction {..})
    = do wroteHeader ← readTVar itrWroteHeader
         if not wroteHeader then
             return $ writeHeader ctx itr
         else
             do noBodyToWrite ← isEmptyTMVar itrBodyToSend
                if noBodyToWrite then
                    do state ← readTVar itrState
                       if state ≡ Done then
                           return $ finalize ctx itr
                       else
                           retry
                else
                    return $ writeBodyChunk ctx itr

writeContinue ∷ HandleLike h ⇒ Context h → Interaction → IO ()
writeContinue ctx@(Context {..}) (Interaction {..})
    = do let cont = Response {
                      resVersion = HttpVersion 1 1
                    , resStatus  = Continue
                    , resHeaders = (∅)
                    }
         cont' ← completeUnconditionalHeaders cConfig cont
         hPutBuilder cHandle $ A.toBuilder $ printResponse cont'
         hFlush cHandle
         atomically $ writeTVar itrWroteContinue True
         awaitSomethingToWrite ctx

writeHeader ∷ HandleLike h ⇒ Context h → Interaction → IO ()
writeHeader ctx@(Context {..}) (Interaction {..})
    = do res ← atomically
               $ do writeTVar itrWroteHeader True
                    readTVar itrResponse
         hPutBuilder cHandle $ A.toBuilder $ printResponse res
         hFlush cHandle
         awaitSomethingToWrite ctx

writeBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO ()
writeBodyChunk ctx@(Context {..}) (Interaction {..})
    = join $
      atomically $
      do willDiscardBody ← readTVar itrWillDiscardBody
         if willDiscardBody then
             do _ ← tryTakeTMVar itrBodyToSend
                return $ awaitSomethingToWrite ctx
         else
             do willChunkBody ← readTVar itrWillChunkBody
                chunk         ← takeTMVar itrBodyToSend
                return $
                    do if willChunkBody then
                           hPutBuilder cHandle $ BB.chunkedTransferEncoding chunk
                       else
                           hPutBuilder cHandle chunk
                       hFlush cHandle
                       awaitSomethingToWrite ctx

finishBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO ()
finishBodyChunk (Context {..}) (Interaction {..})
    = join $
      atomically $
      do willDiscardBody ← readTVar itrWillDiscardBody
         willChunkBody   ← readTVar itrWillChunkBody
         if ((¬) willDiscardBody) ∧ willChunkBody then
             return $
                 do hPutBuilder cHandle BB.chunkedTransferTerminator
                    hFlush cHandle
         else
             return $ return ()

finalize ∷ HandleLike h ⇒ Context h → Interaction → IO ()
finalize ctx@(Context {..}) itr@(Interaction {..})
    = do finishBodyChunk ctx itr
         willClose ← atomically $
                     do queue ← readTVar cQueue
                        case S.viewr queue of
                          EmptyR         → return () -- this should never happen
                          remaining :> _ → writeTVar cQueue remaining
                        readTVar itrWillClose
         if willClose then
             -- reader は恐らく hWaitForInput してゐる最中なので、スレッ
             -- ドを豫め殺して置かないとをかしくなる。
             do killThread cReader
                hClose cHandle
         else
             awaitSomethingToWrite ctx