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.Lazy.Char8 as B
import           Data.ByteString.Lazy.Char8 (ByteString)
import qualified Data.Sequence as S
import           Data.Sequence (Seq)
import           Network.Socket
import           Network.HTTP.Lucu.Config
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))
    , itrResponse     :: !(TVar Response)

    -- FIXME: この三つは本來 TVar であるべきでないので、唯の Bool にす
    -- るに越した事は無いが、それは重要でない。
    , 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 ByteString) -- Resource が受領した部分は削除される

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

    , itrBodyToSend :: !(TVar 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 :: String
defaultPageContentType = "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 = [("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 B.empty

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

         bodyToSend <- newTVarIO B.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 () #-}