{-# LANGUAGE
    BangPatterns
  , OverloadedStrings
  , UnicodeSyntax
  #-}
module Network.HTTP.Lucu.Interaction
    ( Interaction(..)
    , InteractionState(..)
    , InteractionQueue
    , newInteractionQueue
    , newInteraction
    , defaultPageContentType
{-
    , writeItr
    , readItr
    , updateItr
-}
    )
    where
import Blaze.ByteString.Builder (Builder)
import Control.Concurrent.STM
import Data.Ascii (Ascii)
import qualified Data.ByteString as BS
import Data.Sequence (Seq)
import qualified Data.Sequence as S
import Data.Text (Text)
import Network.Socket
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
import OpenSSL.X509

data Interaction = Interaction {
      itrConfig            ∷ !Config
    , itrLocalPort         ∷ !PortNumber
    , itrRemoteAddr        ∷ !SockAddr
    , itrRemoteCert        ∷ !(Maybe X509)
    , itrResourcePath      ∷ !(Maybe [Text])
    , itrRequest           ∷ !(TVar (Maybe Request))
    , itrResponse          ∷ !(TVar Response)

    , itrRequestHasBody    ∷ !(TVar Bool)
    , itrRequestIsChunked  ∷ !(TVar Bool)
    , itrExpectedContinue  ∷ !(TVar Bool)

    , itrReqChunkLength    ∷ !(TVar (Maybe Int))
    , itrReqChunkRemaining ∷ !(TVar (Maybe Int))
    , itrReqChunkIsOver    ∷ !(TVar Bool)
    , itrReqBodyWanted     ∷ !(TVar (Maybe Int))
    , itrReqBodyWasteAll   ∷ !(TVar Bool)
    , itrReceivedBody      ∷ !(TVar (Seq BS.ByteString))
    , itrReceivedBodyLen   ∷ !(TVar Int)

    , itrWillReceiveBody   ∷ !(TVar Bool)
    , itrWillChunkBody     ∷ !(TVar Bool)
    , itrWillDiscardBody   ∷ !(TVar Bool)
    , itrWillClose         ∷ !(TVar Bool)

    , itrBodyToSend        ∷ !(TMVar Builder)
    , itrSentNoBody        ∷ !(TVar Bool)

    , itrState             ∷ !(TVar InteractionState)

    , itrWroteContinue     ∷ !(TVar Bool)
    , itrWroteHeader       ∷ !(TVar Bool)
    }

-- |The interaction state of Resource monad. 'ExaminingRequest' is the
-- initial state.
data InteractionState = ExaminingRequest
                      | GettingBody
                      | DecidingHeader
                      | DecidingBody
                      | Done
                        deriving (Show, Eq, Ord, Enum)

type InteractionQueue = TVar (Seq Interaction)

newInteractionQueue ∷ IO InteractionQueue
newInteractionQueue = newTVarIO S.empty

defaultPageContentType ∷ Ascii
defaultPageContentType = "application/xhtml+xml"

newInteraction ∷ Config → PortNumber → SockAddr → Maybe X509 → Maybe Request → IO Interaction
newInteraction !conf !port !addr !cert !req
    = do request  ← newTVarIO req
         responce ← newTVarIO Response {
                       resVersion = HttpVersion 1 1
                     , resStatus  = Ok
                     , resHeaders = toHeaders [("Content-Type", defaultPageContentType)]
                     }

         requestHasBody     ← newTVarIO False
         requestIsChunked   ← newTVarIO False
         expectedContinue   ← newTVarIO False
         
         reqChunkLength     ← newTVarIO Nothing -- 現在のチャンク長
         reqChunkRemaining  ← newTVarIO Nothing -- 現在のチャンクの殘り
         reqChunkIsOver     ← newTVarIO False   -- 最後のチャンクを讀み終へた
         reqBodyWanted      ← newTVarIO Nothing -- Resource が要求してゐるチャンク長
         reqBodyWasteAll    ← newTVarIO False   -- 殘りの body を讀み捨てよと云ふ要求
         receivedBody       ← newTVarIO S.empty
         receivedBodyLen    ← newTVarIO 0

         willReceiveBody   ← newTVarIO False
         willChunkBody     ← newTVarIO False
         willDiscardBody   ← newTVarIO False
         willClose         ← newTVarIO False

         bodyToSend ← newEmptyTMVarIO
         sentNoBody ← newTVarIO True -- 一度でも bodyToSend が空でなくなったら False

         state ← newTVarIO ExaminingRequest

         wroteContinue ← newTVarIO False
         wroteHeader   ← newTVarIO False

         return Interaction {
                      itrConfig       = conf
                    , itrLocalPort    = port
                    , itrRemoteAddr   = addr
                    , itrRemoteCert   = cert
                    , itrResourcePath = Nothing
                    , itrRequest      = request
                    , itrResponse     = responce

                    , itrRequestHasBody   = requestHasBody
                    , itrRequestIsChunked = requestIsChunked
                    , itrExpectedContinue = expectedContinue

                    , itrReqChunkLength    = reqChunkLength
                    , itrReqChunkRemaining = reqChunkRemaining
                    , itrReqChunkIsOver    = reqChunkIsOver
                    , itrReqBodyWanted     = reqBodyWanted
                    , itrReqBodyWasteAll   = reqBodyWasteAll
                    , itrReceivedBody      = receivedBody
                    , itrReceivedBodyLen   = receivedBodyLen

                    , itrWillReceiveBody   = willReceiveBody
                    , itrWillChunkBody     = willChunkBody
                    , itrWillDiscardBody   = willDiscardBody
                    , itrWillClose         = willClose

                    , itrBodyToSend = bodyToSend
                    , itrSentNoBody = sentNoBody
                    
                    , itrState = state
                    
                    , itrWroteContinue = wroteContinue
                    , itrWroteHeader   = wroteHeader
                    }

{-
chunksToLBS ∷ Seq BS.ByteString → LBS.ByteString
{-# INLINE chunksToLBS #-}
chunksToLBS = LBS.fromChunks ∘ toList

chunksFromLBS ∷ LBS.ByteString → Seq BS.ByteString
{-# INLINE chunksFromLBS #-}
chunksFromLBS = S.fromList ∘ LBS.toChunks
-}

writeItr ∷ (Interaction → TVar a) → a → Interaction → STM ()
{-# INLINE writeItr #-}
writeItr accessor a itr
    = writeTVar (accessor itr) a

readItr ∷ (Interaction → TVar a) → Interaction → STM a
{-# INLINE readItr #-}
readItr accessor itr
    = readTVar (accessor itr)

updateItr ∷ (Interaction → TVar a) → (a → a) → Interaction → STM ()
{-# INLINE updateItr #-}
updateItr accessor updator itr
    = do old ← readItr accessor itr
         writeItr accessor (updator old) itr