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

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

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

    , itrReqBodyWanted     ∷ !(TVar Int)
    , itrReqBodyWasteAll   ∷ !(TVar Bool)
    , itrReqChunkIsOver    ∷ !(TVar Bool)
    , itrReceivedBody      ∷ !(TVar (Seq BS.ByteString))
    , itrReceivedBodyLen   ∷ !(TVar Int)

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

    , itrState             ∷ !(TVar InteractionState)
    }

-- |The interaction state of Resource monad. 'ExaminingRequest' is the
-- initial state.
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 ∷ Ascii
defaultPageContentType = "application/xhtml+xml"

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 = singleton "Content-Type" defaultPageContentType
                   }

         reqBodyWanted   ← newTVarIO 0
         reqBodyWasteAll ← newTVarIO False
         reqChunkIsOver  ← newTVarIO False
         receivedBody    ← newTVarIO S.empty
         receivedBodyLen ← newTVarIO 0

         response        ← newTVarIO res
         willChunkBody   ← newTVarIO False
         willDiscardBody ← newTVarIO False
         willClose       ← newTVarIO False
         bodyToSend      ← newEmptyTMVarIO
         sentNoBodySoFar ← newTVarIO True

         state           ← newTVarIO ExaminingRequest

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

                    , itrExpectedContinue = arExpectedContinue ar
                    , itrReqBodyLength    = arReqBodyLength    ar

                    , itrReqBodyWanted    = reqBodyWanted
                    , itrReqBodyWasteAll  = reqBodyWasteAll
                    , itrReqChunkIsOver   = reqChunkIsOver
                    , itrReceivedBody     = receivedBody
                    , itrReceivedBodyLen  = receivedBodyLen

                    , itrResponse         = response
                    , itrWillChunkBody    = willChunkBody
                    , itrWillDiscardBody  = willDiscardBody
                    , itrWillClose        = willClose
                    , itrBodyToSend       = bodyToSend
                    , itrSentNoBodySoFar  = sentNoBodySoFar
                    
                    , itrState            = state
                    }

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