{-# LANGUAGE
    DoAndIfThenElse
  , RecordWildCards
  , ScopedTypeVariables
  , UnicodeSyntax
  #-}
module Network.HTTP.Lucu.ResponseWriter
    ( responseWriter
    )
    where
import qualified Blaze.ByteString.Builder.HTTP as BB
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import qualified Data.Ascii as A
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
      }

data Phase = Initial
           | WroteContinue
           | WroteHeader
             deriving (Eq, Ord, Show)

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
         case S.viewr queue of
           EmptyR        → retry
           queue' :> itr → do writeTVar cQueue queue'
                              return $ awaitSomethingToWriteOn ctx itr Initial

-- GettingBody 状態にあり、Continue が期待されてゐて、それがまだ送信前
-- なのであれば、Continue を送信する。
awaitSomethingToWriteOn ∷ HandleLike h
                        ⇒ Context h
                        → Interaction
                        → Phase
                        → IO ()
awaitSomethingToWriteOn ctx itr phase
    = join $
      atomically $
      do state ← readTVar $ itrState itr
         if state ≡ GettingBody then
             writeContinueIfNeeded ctx itr phase
         else
             if state ≥ DecidingBody then
                 writeHeaderOrBodyIfNeeded ctx itr phase
             else
                 retry

writeContinueIfNeeded ∷ HandleLike h
                      ⇒ Context h
                      → Interaction
                      → Phase
                      → STM (IO ())
writeContinueIfNeeded ctx itr@(Interaction {..}) phase
    | phase ≡ Initial ∧ itrExpectedContinue ≡ Just True
        = do reqBodyWanted ← readTVar itrReqBodyWanted
             if reqBodyWanted > 0 then
                 return $ writeContinue ctx itr
             else
                 retry
    | otherwise
        = retry

-- DecidingBody 以降の状態にあり、まだヘッダを出力する前であれば、ヘッ
-- ダを出力する。ヘッダ出力後であり、bodyToSend が空でなければ、それを
-- 出力する。空である時は、もし状態がDone であれば後処理をする。
writeHeaderOrBodyIfNeeded ∷ HandleLike h
                          ⇒ Context h
                          → Interaction
                          → Phase
                          → STM (IO ())
writeHeaderOrBodyIfNeeded ctx itr@(Interaction {..}) phase
    | phase < WroteHeader
        = return $ writeHeader ctx itr
    | otherwise
        = 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 phase

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

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

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

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