Lucu-0.7.0.2: Network/HTTP/Lucu/Interaction.hs

{-# LANGUAGE
    BangPatterns
  , UnicodeSyntax
  #-}
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
import           OpenSSL.X509

data Interaction = Interaction {
      itrConfig       :: !Config
    , itrLocalPort    :: !PortNumber
    , itrRemoteAddr   :: !SockAddr
    , itrRemoteCert   :: !(Maybe X509)
    , 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 -> 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 [(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
                    , 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

                    , 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
    = fmap reader $ readTVar (accessor itr)


readItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
readItrF !itr !accessor !reader
    = 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
    = 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)
{-# SPECIALIZE updateItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> a) -> STM () #-}