{-# 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 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    ∷ !(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    ∷ !(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 ∷ StatusCode sc ⇒ NormalInteraction → sc → STM ()
setResponseStatus (NI {..}) sc
    = do res ← readTVar niResponse
         let res' = res {
                      resStatus = fromStatusCode sc
                    }
         writeTVar niResponse res'

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