{-# LANGUAGE
    OverloadedStrings
  , RecordWildCards
  , UnicodeSyntax
  #-}
module Network.HTTP.Lucu.Interaction
    ( Interaction(..)
    , InteractionState(..)
    , InteractionQueue
    , ReceiveBodyRequest(..)
    , newInteractionQueue
    , newInteraction

    , setResponseStatus
    )
    where
import Blaze.ByteString.Builder (Builder)
import Control.Concurrent.STM
import qualified Data.ByteString as Strict
import Data.Monoid.Unicode
import Data.Sequence (Seq)
import qualified Data.Sequence as S
import Network.Socket
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Preprocess
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 [Strict.ByteString])
    , itrRequest           ∷ !(Maybe Request)

    , itrExpectedContinue  ∷ !(Maybe Bool)
    , itrReqBodyLength     ∷ !(Maybe RequestBodyLength)

    , itrReceiveBodyReq    ∷ !(TMVar ReceiveBodyRequest)
    , itrReceivedBody      ∷ !(TMVar Strict.ByteString)

    , itrSendContinue      ∷ !(TMVar Bool)
    , itrResponse          ∷ !(TVar Response)
    , itrWillChunkBody     ∷ !(TVar Bool)
    , itrWillDiscardBody   ∷ !(TVar Bool)
    , itrWillClose         ∷ !(TVar Bool)
    , itrResponseHasCType  ∷ !(TVar Bool)
    , itrBodyToSend        ∷ !(TMVar Builder)

    , itrState             ∷ !(TVar InteractionState)
    }

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

type InteractionQueue = TVar (Seq Interaction)

data ReceiveBodyRequest
    = ReceiveBody !Int -- ^ Maximum number of octets to receive.
    | WasteAll
    deriving (Show, Eq)

newInteractionQueue ∷ IO InteractionQueue
newInteractionQueue = newTVarIO S.empty

newInteraction ∷ Config
               → PortNumber
               → SockAddr
               → Maybe X509
               → Either StatusCode Request
               → IO Interaction
newInteraction conf@(Config {..}) port addr cert request
    = do let ar  = preprocess cnfServerHost port request
             res = Response {
                     resVersion = HttpVersion 1 1
                   , resStatus  = arInitialStatus ar
                   , resHeaders = (∅)
                   }

         receiveBodyReq   ← newEmptyTMVarIO
         receivedBody     ← newEmptyTMVarIO

         sendContinue     ← newEmptyTMVarIO
         response         ← newTVarIO res
         willChunkBody    ← newTVarIO False
         willDiscardBody  ← newTVarIO (arWillDiscardBody ar)
         willClose        ← newTVarIO (arWillClose       ar)
         bodyToSend       ← newEmptyTMVarIO
         responseHasCType ← newTVarIO False

         state            ← newTVarIO ExaminingRequest

         return Interaction {
                      itrConfig           = conf
                    , itrLocalPort        = port
                    , itrRemoteAddr       = addr
                    , itrRemoteCert       = cert
                    , itrResourcePath     = Nothing
                    , itrRequest          = arRequest ar

                    , itrExpectedContinue = arExpectedContinue ar
                    , itrReqBodyLength    = arReqBodyLength    ar

                    , itrReceiveBodyReq   = receiveBodyReq
                    , itrReceivedBody     = receivedBody

                    , itrSendContinue     = sendContinue
                    , itrResponse         = response
                    , itrWillChunkBody    = willChunkBody
                    , itrWillDiscardBody  = willDiscardBody
                    , itrWillClose        = willClose
                    , itrResponseHasCType = responseHasCType
                    , itrBodyToSend       = bodyToSend
                    
                    , itrState            = state
                    }

setResponseStatus ∷ Interaction → StatusCode → STM ()
setResponseStatus (Interaction {..}) sc
    = do res ← readTVar itrResponse
         let res' = res {
                      resStatus = sc
                    }
         writeTVar itrResponse res'