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

    , SyntacticallyInvalidInteraction(..)
    , mkSyntacticallyInvalidInteraction

    , SemanticallyInvalidInteraction(..)
    , mkSemanticallyInvalidInteraction

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

    , InteractionQueue
    , mkInteractionQueue

    , getCurrentDate
    )
    where
import Blaze.ByteString.Builder (Builder)
import Control.Applicative
import Control.Concurrent.STM
import Data.Ascii (Ascii)
import Data.ByteString (ByteString)
import Data.Convertible.Base
import Data.Monoid.Unicode
import Data.Proxy
import Data.Sequence (Seq)
import Data.Time
import Data.Time.Format.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 Network.HTTP.Lucu.Response.StatusCode
import Network.HTTP.Lucu.Utils
#if defined(HAVE_SSL)
import OpenSSL.X509
#endif
import Prelude.Unicode

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

-- |'EndOfInteraction' is an 'Interaction' indicating the end of
-- (possibly pipelined) requests. The connection has already been
-- closed so no need to reply anything.
data EndOfInteraction = EndOfInteraction
    deriving Typeable
instance Interaction EndOfInteraction

-- |'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 conf@(Config {..})
    = do date ← getCurrentDate
         let res  = setHeader "Server"       cnfServerSoftware      $
                    setHeader "Date"         date                   $
                    setHeader "Content-Type" defaultPageContentType $
                    emptyResponse BadRequest
             body = defaultPageForResponse conf 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
      , 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 $
                    ( if arWillChunkBody
                      then setHeader "Transfer-Encoding" "chunked"
                      else id
                    ) $
                    ( if arWillClose
                      then setHeader "Connection" "close"
                      else id
                    ) $
                    emptyResponse arInitialStatus
             body = defaultPageForResponse config (Just arRequest) res
         return SEI {
                  seiRequest          = arRequest
                , seiExpectedContinue = arExpectedContinue
                , seiReqBodyLength    = arReqBodyLength

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

-- |'NormalInteraction' is an 'Interaction' with a semantically
-- correct 'Request'.
data NormalInteraction
    = NI {
        niConfig           ∷ !Config
      , niRemoteAddr       ∷ !SockAddr
#if defined(HAVE_SSL)
      , niRemoteCert       ∷ !(Maybe X509)
#endif
      , niRequest          ∷ !Request
      , niResourcePath     ∷ !Path
      , niExpectedContinue ∷ !Bool
      , niReqBodyLength    ∷ !(Maybe RequestBodyLength)

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

      , niResponse         ∷ !(TVar Response)
      , niSendContinue     ∷ !(TMVar Bool)
      , niWillChunkBody    ∷ !Bool
      , niWillClose        ∷ !(TVar Bool)
      , niResponseHasCType ∷ !(TVar Bool)
      -- FIXME: use TBChan Builder (in stm-chans package)
      , 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
#if defined(HAVE_SSL)
                    → Maybe X509
#endif
                    → AugmentedRequest
                    → Path
                    → IO NormalInteraction
#if defined(HAVE_SSL)
mkNormalInteraction config remoteAddr remoteCert (AugmentedRequest {..}) rsrcPath
#else
mkNormalInteraction config remoteAddr (AugmentedRequest {..}) rsrcPath
#endif
    = do receiveBodyReq   ← newEmptyTMVarIO
         receivedBody     ← newEmptyTMVarIO

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

         state            ← newTVarIO ExaminingRequest

         return NI {
                  niConfig           = config
                , niRemoteAddr       = remoteAddr
#if defined(HAVE_SSL)
                , niRemoteCert       = remoteCert
#endif
                , niRequest          = arRequest
                , niResourcePath     = rsrcPath
                , niExpectedContinue = arExpectedContinue
                , niReqBodyLength    = arReqBodyLength

                , niReceiveBodyReq   = receiveBodyReq
                , niReceivedBody     = receivedBody

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

                , niState            = state
                }

type InteractionQueue = TVar (Seq SomeInteraction)

mkInteractionQueue ∷ IO InteractionQueue
{-# INLINE mkInteractionQueue #-}
mkInteractionQueue = newTVarIO (∅)

getCurrentDate ∷ IO Ascii
{-# INLINE getCurrentDate #-}
getCurrentDate = flip proxy http ∘ cs <$> getCurrentTime