{-# LANGUAGE OverloadedStrings #-}

module Network.HTTP2.Arch.Types where

import qualified Control.Exception as E
import Data.ByteString.Builder (Builder)
import Data.IORef
import Data.IntMap.Strict (IntMap)
import Data.Typeable
import qualified Network.HTTP.Types as H
import UnliftIO.Concurrent
import UnliftIO.Exception (SomeException)
import UnliftIO.STM

import Imports
import Network.HPACK
import Network.HTTP2.Arch.File
import Network.HTTP2.Frame

----------------------------------------------------------------

-- | "http" or "https".
type Scheme = ByteString

-- | Authority.
type Authority = ByteString

-- | Path.
type Path = ByteString

----------------------------------------------------------------

type InpBody = IO ByteString

data OutBody = OutBodyNone
             -- | Streaming body takes a write action and a flush action.
             | OutBodyStreaming ((Builder -> IO ()) -> IO () -> IO ())
             | OutBodyBuilder Builder
             | OutBodyFile FileSpec

-- | Input object
data InpObj = InpObj {
    InpObj -> HeaderTable
inpObjHeaders  :: HeaderTable   -- ^ Accessor for headers.
  , InpObj -> Maybe SettingsValue
inpObjBodySize :: Maybe Int     -- ^ Accessor for body length specified in content-length:.
  , InpObj -> InpBody
inpObjBody     :: InpBody       -- ^ Accessor for body.
  , InpObj -> IORef (Maybe HeaderTable)
inpObjTrailers :: IORef (Maybe HeaderTable) -- ^ Accessor for trailers.
  }

instance Show InpObj where
    show :: InpObj -> String
show (InpObj (TokenHeaderList
thl,ValueTable
_) Maybe SettingsValue
_ InpBody
_body IORef (Maybe HeaderTable)
_tref) = forall a. Show a => a -> String
show TokenHeaderList
thl

-- | Output object
data OutObj = OutObj {
    OutObj -> [Header]
outObjHeaders  :: [H.Header]    -- ^ Accessor for header.
  , OutObj -> OutBody
outObjBody     :: OutBody       -- ^ Accessor for outObj body.
  , OutObj -> TrailersMaker
outObjTrailers :: TrailersMaker -- ^ Accessor for trailers maker.
  }

instance Show OutObj where
    show :: OutObj -> String
show (OutObj [Header]
hdr OutBody
_ TrailersMaker
_) = forall a. Show a => a -> String
show [Header]
hdr

-- | Trailers maker. A chunks of the response body is passed
--   with 'Just'. The maker should update internal state
--   with the 'ByteString' and return the next trailers maker.
--   When response body reaches its end,
--   'Nothing' is passed and the maker should generate
--   trailers. An example:
--
--   > {-# LANGUAGE BangPatterns #-}
--   > import Data.ByteString (ByteString)
--   > import qualified Data.ByteString.Char8 as C8
--   > import Crypto.Hash (Context, SHA1) -- cryptonite
--   > import qualified Crypto.Hash as CH
--   >
--   > -- Strictness is important for Context.
--   > trailersMaker :: Context SHA1 -> Maybe ByteString -> IO NextTrailersMaker
--   > trailersMaker ctx Nothing = return $ Trailers [("X-SHA1", sha1)]
--   >   where
--   >     !sha1 = C8.pack $ show $ CH.hashFinalize ctx
--   > trailersMaker ctx (Just bs) = return $ NextTrailersMaker $ trailersMaker ctx'
--   >   where
--   >     !ctx' = CH.hashUpdate ctx bs
--
--   Usage example:
--
--   > let h2rsp = responseFile ...
--   >     maker = trailersMaker (CH.hashInit :: Context SHA1)
--   >     h2rsp' = setResponseTrailersMaker h2rsp maker
--
type TrailersMaker = Maybe ByteString -> IO NextTrailersMaker

-- | TrailersMake to create no trailers.
defaultTrailersMaker :: TrailersMaker
defaultTrailersMaker :: TrailersMaker
defaultTrailersMaker Maybe HeaderValue
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Header] -> NextTrailersMaker
Trailers []
defaultTrailersMaker Maybe HeaderValue
_       = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TrailersMaker -> NextTrailersMaker
NextTrailersMaker TrailersMaker
defaultTrailersMaker

-- | Either the next trailers maker or final trailers.
data NextTrailersMaker = NextTrailersMaker TrailersMaker
                       | Trailers [H.Header]

----------------------------------------------------------------

-- | File specification.
data FileSpec = FileSpec FilePath FileOffset ByteCount deriving (FileSpec -> FileSpec -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FileSpec -> FileSpec -> Bool
$c/= :: FileSpec -> FileSpec -> Bool
== :: FileSpec -> FileSpec -> Bool
$c== :: FileSpec -> FileSpec -> Bool
Eq, SettingsValue -> FileSpec -> ShowS
[FileSpec] -> ShowS
FileSpec -> String
forall a.
(SettingsValue -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FileSpec] -> ShowS
$cshowList :: [FileSpec] -> ShowS
show :: FileSpec -> String
$cshow :: FileSpec -> String
showsPrec :: SettingsValue -> FileSpec -> ShowS
$cshowsPrec :: SettingsValue -> FileSpec -> ShowS
Show)

----------------------------------------------------------------

data OpenState =
    JustOpened
  | Continued [HeaderBlockFragment]
              Int  -- Total size
              Int  -- The number of continuation frames
              Bool -- End of stream
  | NoBody HeaderTable
  | HasBody HeaderTable
  | Body (TQueue ByteString)
         (Maybe Int) -- received Content-Length
                     -- compared the body length for error checking
         (IORef Int) -- actual body length
         (IORef (Maybe HeaderTable)) -- trailers

data ClosedCode = Finished
                | Killed
                | Reset ErrorCode
                | ResetByMe SomeException
                deriving SettingsValue -> ClosedCode -> ShowS
[ClosedCode] -> ShowS
ClosedCode -> String
forall a.
(SettingsValue -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ClosedCode] -> ShowS
$cshowList :: [ClosedCode] -> ShowS
show :: ClosedCode -> String
$cshow :: ClosedCode -> String
showsPrec :: SettingsValue -> ClosedCode -> ShowS
$cshowsPrec :: SettingsValue -> ClosedCode -> ShowS
Show

----------------------------------------------------------------

data StreamState =
    Idle
  | Open OpenState
  | HalfClosedRemote
  | HalfClosedLocal ClosedCode
  | Closed ClosedCode
  | Reserved

instance Show StreamState where
    show :: StreamState -> String
show StreamState
Idle                = String
"Idle"
    show Open{}              = String
"Open"
    show StreamState
HalfClosedRemote    = String
"HalfClosedRemote"
    show (HalfClosedLocal ClosedCode
e) = String
"HalfClosedLocal: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ClosedCode
e
    show (Closed ClosedCode
e)          = String
"Closed: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ClosedCode
e
    show StreamState
Reserved            = String
"Reserved"

----------------------------------------------------------------

data Stream = Stream {
    Stream -> SettingsValue
streamNumber     :: StreamId
  , Stream -> IORef StreamState
streamState      :: IORef StreamState
  , Stream -> TVar SettingsValue
streamWindow     :: TVar WindowSize
  , Stream -> MVar InpObj
streamInput      :: MVar InpObj -- Client only
  }

instance Show Stream where
  show :: Stream -> String
show Stream
s = forall a. Show a => a -> String
show (Stream -> SettingsValue
streamNumber Stream
s)

----------------------------------------------------------------

newtype StreamTable = StreamTable (IORef (IntMap Stream))

----------------------------------------------------------------

data Input a = Input a InpObj

data Output a = Output {
    forall a. Output a -> a
outputStream   :: a
  , forall a. Output a -> OutObj
outputObject   :: OutObj
  , forall a. Output a -> OutputType
outputType     :: OutputType
  , forall a. Output a -> Maybe (TBQueue StreamingChunk)
outputStrmQ    :: Maybe (TBQueue StreamingChunk)
  , forall a. Output a -> IO ()
outputSentinel :: IO ()
  }

data OutputType = OObj
                | OWait (IO ())
                | OPush TokenHeaderList StreamId -- associated stream id from client
                | ONext DynaNext TrailersMaker

----------------------------------------------------------------

type DynaNext = Buffer -> BufferSize -> WindowSize -> IO Next

type BytesFilled = Int

data Next = Next BytesFilled (Maybe DynaNext)

----------------------------------------------------------------

data Control = CFinish
             | CGoaway    ByteString
             | CFrame     ByteString
             | CSettings  ByteString SettingsList
             | CSettings0 ByteString ByteString SettingsList

----------------------------------------------------------------

data StreamingChunk = StreamingFinished
                    | StreamingFlush
                    | StreamingBuilder Builder

----------------------------------------------------------------

type ReasonPhrase = ShortByteString

-- | The connection error or the stream error.
--   Stream errors are treated as connection errors since
--   there are no good recovery ways.
--   `ErrorCode` in connection errors should be the highest stream identifier
--   but in this implementation it identifies the stream that
--   caused this error.
data HTTP2Error =
    ConnectionIsClosed -- NoError
  | ConnectionErrorIsReceived ErrorCode StreamId ReasonPhrase
  | ConnectionErrorIsSent     ErrorCode StreamId ReasonPhrase
  | StreamErrorIsReceived     ErrorCode StreamId
  | StreamErrorIsSent         ErrorCode StreamId
  | BadThingHappen E.SomeException
  deriving (SettingsValue -> HTTP2Error -> ShowS
[HTTP2Error] -> ShowS
HTTP2Error -> String
forall a.
(SettingsValue -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HTTP2Error] -> ShowS
$cshowList :: [HTTP2Error] -> ShowS
show :: HTTP2Error -> String
$cshow :: HTTP2Error -> String
showsPrec :: SettingsValue -> HTTP2Error -> ShowS
$cshowsPrec :: SettingsValue -> HTTP2Error -> ShowS
Show, Typeable)

instance E.Exception HTTP2Error

----------------------------------------------------------------

-- | Checking 'SettingsList' and reporting an error if any.
--
-- >>> checkSettingsList [(SettingsEnablePush,2)]
-- Just (ConnectionErrorIsSent ProtocolError 0 "enable push must be 0 or 1")
checkSettingsList :: SettingsList -> Maybe HTTP2Error
checkSettingsList :: SettingsList -> Maybe HTTP2Error
checkSettingsList SettingsList
settings = case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (SettingsKey, SettingsValue) -> Maybe HTTP2Error
checkSettingsValue SettingsList
settings of
    []    -> forall a. Maybe a
Nothing
    (HTTP2Error
x:[HTTP2Error]
_) -> forall a. a -> Maybe a
Just HTTP2Error
x

checkSettingsValue :: (SettingsKey,SettingsValue) -> Maybe HTTP2Error
checkSettingsValue :: (SettingsKey, SettingsValue) -> Maybe HTTP2Error
checkSettingsValue (SettingsKey
SettingsEnablePush,SettingsValue
v)
  | SettingsValue
v forall a. Eq a => a -> a -> Bool
/= SettingsValue
0 Bool -> Bool -> Bool
&& SettingsValue
v forall a. Eq a => a -> a -> Bool
/= SettingsValue
1 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ErrorCode -> SettingsValue -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError SettingsValue
0 ReasonPhrase
"enable push must be 0 or 1"
checkSettingsValue (SettingsKey
SettingsInitialWindowSize,SettingsValue
v)
  | SettingsValue
v forall a. Ord a => a -> a -> Bool
> SettingsValue
2147483647   = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ErrorCode -> SettingsValue -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
FlowControlError SettingsValue
0 ReasonPhrase
"Window size must be less than or equal to 65535"
checkSettingsValue (SettingsKey
SettingsMaxFrameSize,SettingsValue
v)
  | SettingsValue
v forall a. Ord a => a -> a -> Bool
< SettingsValue
16384 Bool -> Bool -> Bool
|| SettingsValue
v forall a. Ord a => a -> a -> Bool
> SettingsValue
16777215 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ErrorCode -> SettingsValue -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError SettingsValue
0 ReasonPhrase
"Max frame size must be in between 16384 and 16777215"
checkSettingsValue (SettingsKey, SettingsValue)
_ = forall a. Maybe a
Nothing