{-# LANGUAGE
    DeriveDataTypeable
  , ExistentialQuantification
  , OverloadedStrings
  , RecordWildCards
  , UnicodeSyntax
  #-}
module Network.HTTP.Lucu.Interaction
    ( Interaction(..)
    , SomeInteraction(..)

    , SyntacticallyInvalidInteraction(..)
    , mkSyntacticallyInvalidInteraction

    , SemanticallyInvalidInteraction(..)
    , mkSemanticallyInvalidInteraction

    , NormalInteraction(..)
    , InteractionState(..)
    , ReceiveBodyRequest(..)
    , mkNormalInteraction

    , InteractionQueue
    , mkInteractionQueue

    , setResponseStatus
    , getCurrentDate
    )
    where
import Blaze.ByteString.Builder (Builder)
import Control.Applicative
import Control.Concurrent.STM
import Data.Ascii (Ascii)
import qualified Data.ByteString as Strict
import Data.Monoid.Unicode
import Data.Sequence (Seq)
import qualified Data.Strict.Maybe as S
import Data.Time
import qualified Data.Time.HTTP as HTTP
import Data.Typeable
import Network.Socket
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.DefaultPage
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.Preprocess
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
import OpenSSL.X509

class Typeable i ⇒ Interaction i where
    toInteraction ∷ i → SomeInteraction
    toInteraction = SomeInteraction

    fromInteraction ∷ SomeInteraction → Maybe i
    fromInteraction (SomeInteraction i) = cast i

data SomeInteraction
    = ∀i. Interaction i ⇒ SomeInteraction !i
    deriving Typeable

instance Interaction SomeInteraction where
    toInteraction   = id
    fromInteraction = Just

-- |'SyntacticallyInvalidInteraction' is an 'Interaction' without even
-- a syntactically valid 'Request'. The response code will always be
-- 'BadRequest'.
data SyntacticallyInvalidInteraction
    = SYI {
        syiResponse   ∷ !Response
      , syiBodyToSend ∷ !Builder
      }
    deriving Typeable
instance Interaction SyntacticallyInvalidInteraction

mkSyntacticallyInvalidInteraction ∷ Config
                                  → IO SyntacticallyInvalidInteraction
mkSyntacticallyInvalidInteraction config@(Config {..})
    = do date ← getCurrentDate
         let res  = setHeader "Server"       cnfServerSoftware      $
                    setHeader "Date"         date                   $
                    setHeader "Content-Type" defaultPageContentType $
                    emptyResponse BadRequest
             body = getDefaultPage config Nothing res
         return SYI {
                  syiResponse   = res
                , syiBodyToSend = body
                }

-- |'SemanticallyInvalidInteraction' is an 'Interaction' without a
-- semantically valid 'Request'. The response code will always satisfy
-- 'isError'.
data SemanticallyInvalidInteraction
    = SEI {
        seiRequest          ∷ !Request
      , seiExpectedContinue ∷ !Bool
      , seiReqBodyLength    ∷ !(S.Maybe RequestBodyLength)

      , seiResponse         ∷ !Response
      , seiWillChunkBody    ∷ !Bool
      , seiWillDiscardBody  ∷ !Bool
      , seiWillClose        ∷ !Bool
      , seiBodyToSend       ∷ !Builder
      }
    deriving Typeable
instance Interaction SemanticallyInvalidInteraction

mkSemanticallyInvalidInteraction ∷ Config
                                 → AugmentedRequest
                                 → IO SemanticallyInvalidInteraction
mkSemanticallyInvalidInteraction config@(Config {..}) (AugmentedRequest {..})
    = do date ← getCurrentDate
         let res  = setHeader "Server"       cnfServerSoftware      $
                    setHeader "Date"         date                   $
                    setHeader "Content-Type" defaultPageContentType $
                    emptyResponse arInitialStatus
             body = getDefaultPage config (Just arRequest) res
         return SEI {
                  seiRequest          = arRequest
                , seiExpectedContinue = arExpectedContinue
                , seiReqBodyLength    = arReqBodyLength

                , seiResponse         = res
                , seiWillChunkBody    = arWillChunkBody
                , seiWillDiscardBody  = arWillDiscardBody
                , seiWillClose        = arWillClose
                , seiBodyToSend       = body
                }

-- |'NormalInteraction' is an 'Interaction' with a semantically
-- correct 'Request'.
data NormalInteraction
    = NI {
        niConfig           ∷ !Config
      , niRemoteAddr       ∷ !SockAddr
      , niRemoteCert       ∷ !(Maybe X509)
      , niRequest          ∷ !Request
      , niResourcePath     ∷ ![Strict.ByteString]
      , niExpectedContinue ∷ !Bool
      , niReqBodyLength    ∷ !(S.Maybe RequestBodyLength)

      , niReceiveBodyReq   ∷ !(TMVar ReceiveBodyRequest)
      , niReceivedBody     ∷ !(TMVar Strict.ByteString)

      , niResponse         ∷ !(TVar Response)
      , niSendContinue     ∷ !(TMVar Bool)
      , niWillChunkBody    ∷ !Bool
      , niWillDiscardBody  ∷ !(TVar Bool)
      , niWillClose        ∷ !(TVar Bool)
      , niResponseHasCType ∷ !(TVar Bool)
      , niBodyToSend       ∷ !(TMVar Builder)

      , niState            ∷ !(TVar InteractionState)
      }
    deriving Typeable
instance Interaction NormalInteraction

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

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

mkNormalInteraction ∷ Config
                    → SockAddr
                    → Maybe X509
                    → AugmentedRequest
                    → [Strict.ByteString]
                    → IO NormalInteraction
mkNormalInteraction config remoteAddr remoteCert (AugmentedRequest {..}) rsrcPath
    = do receiveBodyReq   ← newEmptyTMVarIO
         receivedBody     ← newEmptyTMVarIO

         response         ← newTVarIO $ emptyResponse arInitialStatus
         sendContinue     ← newEmptyTMVarIO
         willDiscardBody  ← newTVarIO arWillDiscardBody
         willClose        ← newTVarIO arWillClose
         responseHasCType ← newTVarIO False
         bodyToSend       ← newEmptyTMVarIO

         state            ← newTVarIO ExaminingRequest

         return NI {
                  niConfig           = config
                , niRemoteAddr       = remoteAddr
                , niRemoteCert       = remoteCert
                , niRequest          = arRequest
                , niResourcePath     = rsrcPath
                , niExpectedContinue = arExpectedContinue
                , niReqBodyLength    = arReqBodyLength

                , niReceiveBodyReq   = receiveBodyReq
                , niReceivedBody     = receivedBody

                , niResponse         = response
                , niSendContinue     = sendContinue
                , niWillChunkBody    = arWillChunkBody
                , niWillDiscardBody  = willDiscardBody
                , niWillClose        = willClose
                , niResponseHasCType = responseHasCType
                , niBodyToSend       = bodyToSend

                , niState            = state
                }

type InteractionQueue = TVar (Seq SomeInteraction)

mkInteractionQueue ∷ IO InteractionQueue
mkInteractionQueue = newTVarIO (∅)

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

getCurrentDate ∷ IO Ascii
getCurrentDate = HTTP.toAscii <$> getCurrentTime