module Network.HTTP.Lucu.Interaction
    ( Interaction(..)
    , InteractionState(..)
    , InteractionQueue
    , newInteractionQueue
    , newInteraction
    , defaultPageContentType

    , writeItr
    , readItr
    , readItrF
    , updateItr
    , updateItrF
    )
    where

import           Control.Concurrent.STM
import qualified Data.ByteString as Strict (ByteString)
import qualified Data.ByteString.Lazy as Lazy (ByteString)
import           Data.ByteString.Char8 as C8 hiding (ByteString)
import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)
import qualified Data.Sequence as S
import           Data.Sequence (Seq)
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

data Interaction = Interaction {
      itrConfig       :: !Config
    , itrRemoteAddr   :: !SockAddr
    , itrResourcePath :: !(Maybe [String])
    , itrRequest      :: !(TVar (Maybe Request)) -- FIXME: TVar である必要無し
    , itrResponse     :: !(TVar Response)

    , itrRequestHasBody    :: !(TVar Bool) -- FIXME: TVar である必要無し
    , itrRequestIsChunked  :: !(TVar Bool) -- FIXME: TVar である必要無し
    , itrExpectedContinue  :: !(TVar Bool) -- FIXME: TVar である必要無し

    , itrReqChunkLength    :: !(TVar (Maybe Int))
    , itrReqChunkRemaining :: !(TVar (Maybe Int))
    , itrReqChunkIsOver    :: !(TVar Bool)
    , itrReqBodyWanted     :: !(TVar (Maybe Int))
    , itrReqBodyWasteAll   :: !(TVar Bool)
    , itrReceivedBody      :: !(TVar Lazy.ByteString) -- Resource が受領した部分は削除される

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

    , itrBodyToSend :: !(TVar Lazy.ByteString)
    , itrBodyIsNull :: !(TVar Bool)

    , itrState :: !(TVar InteractionState)

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

-- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期
-- 状態は ExaminingRequest。
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 :: Strict.ByteString
defaultPageContentType = C8.pack "application/xhtml+xml"


newInteraction :: Config -> SockAddr -> Maybe Request -> IO Interaction
newInteraction conf addr req
    = conf `seq` addr `seq` req `seq`
      do request  <- newTVarIO $ req
         responce <- newTVarIO $ Response {
                       resVersion = HttpVersion 1 1
                     , resStatus  = Ok
                     , resHeaders = toHeaders [(C8.pack "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 L8.empty

         willReceiveBody   <- newTVarIO False
         willChunkBody     <- newTVarIO False
         willDiscardBody   <- newTVarIO False
         willClose         <- newTVarIO False

         bodyToSend <- newTVarIO L8.empty
         bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False

         state <- newTVarIO ExaminingRequest

         wroteContinue <- newTVarIO False
         wroteHeader   <- newTVarIO False

         return $ Interaction {
                      itrConfig       = conf
                    , itrRemoteAddr   = addr
                    , itrResourcePath = Nothing
                    , itrRequest      = request
                    , itrResponse     = responce

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

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

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

                    , itrBodyToSend = bodyToSend
                    , itrBodyIsNull = bodyIsNull
                    
                    , itrState = state
                    
                    , itrWroteContinue = wroteContinue
                    , itrWroteHeader   = wroteHeader
                    }


writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM ()
writeItr itr accessor value
    = itr `seq` accessor `seq` value `seq`
      writeTVar (accessor itr) value


readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
readItr itr accessor reader
    = itr `seq` accessor `seq` reader `seq`
      readTVar (accessor itr) >>= return . reader


readItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
readItrF itr accessor reader
    = itr `seq` accessor `seq` reader `seq`
      readItr itr accessor (fmap reader)
{-# SPECIALIZE readItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> b) -> STM (Maybe b) #-}


updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
updateItr itr accessor updator
    = itr `seq` accessor `seq` updator `seq`
      do old <- readItr itr accessor id
         writeItr itr accessor (updator old)


updateItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
updateItrF itr accessor updator
    = itr `seq` accessor `seq` updator `seq`
      updateItr itr accessor (fmap updator)
{-# SPECIALIZE updateItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> a) -> STM () #-}