module Network.HTTP.Lucu.Interaction
    ( Interaction(..)
    , InteractionState(..)
    , InteractionQueue
    , newInteractionQueue -- IO InteractionQueue
    , newInteraction      -- Config -> HostName -> Maybe Request -> IO Interaction

    , writeItr   -- Interaction -> (Interaction -> TVar a) -> a -> STM ()
    , readItr    -- Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
    , readItrF   -- (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
    , updateItr  -- Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
    , updateItrF -- (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
    )
    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
import           Network.HTTP.Lucu.Config
import           Network.HTTP.Lucu.Request
import           Network.HTTP.Lucu.Response

data Interaction = Interaction {
      itrConfig       :: Config
    , itrRemoteHost   :: HostName
    , itrResourcePath :: Maybe [String]
    , itrRequest      :: Maybe Request
    , itrResponse     :: TVar (Maybe Response)

    -- FIXME: この三つは本來 TVar であるべきでないので、唯の Bool にす
    -- るに越した事は無いが、それは重要でない。そんな golf で自分の貴重
    -- な時間を /dev/null に突っ込むのは、他にしたい事が何も無くなって
    -- からにすべき。
    , 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


newInteraction :: Config -> HostName -> Maybe Request -> IO Interaction
newInteraction conf host req
    = do responce <- newTVarIO Nothing

         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
                    , itrRemoteHost   = host
                    , itrResourcePath = Nothing
                    , itrRequest      = req
                    , 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
    = writeTVar (accessor itr) value


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


readItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
readItrF itr accessor reader
    = readItr itr accessor (fmap reader)


updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
updateItr itr accessor updator
    = 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
    = updateItr itr accessor (fmap updator)