{-# 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) = TokenHeaderList -> String
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
_) = [Header] -> String
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 = NextTrailersMaker -> IO NextTrailersMaker
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (NextTrailersMaker -> IO NextTrailersMaker)
-> NextTrailersMaker -> IO NextTrailersMaker
forall a b. (a -> b) -> a -> b
$ [Header] -> NextTrailersMaker
Trailers []
defaultTrailersMaker Maybe HeaderValue
_       = NextTrailersMaker -> IO NextTrailersMaker
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (NextTrailersMaker -> IO NextTrailersMaker)
-> NextTrailersMaker -> IO NextTrailersMaker
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
(FileSpec -> FileSpec -> Bool)
-> (FileSpec -> FileSpec -> Bool) -> Eq FileSpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FileSpec -> FileSpec -> Bool
== :: FileSpec -> FileSpec -> Bool
$c/= :: FileSpec -> FileSpec -> Bool
/= :: FileSpec -> FileSpec -> Bool
Eq, SettingsValue -> FileSpec -> ShowS
[FileSpec] -> ShowS
FileSpec -> String
(SettingsValue -> FileSpec -> ShowS)
-> (FileSpec -> String) -> ([FileSpec] -> ShowS) -> Show FileSpec
forall a.
(SettingsValue -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: SettingsValue -> FileSpec -> ShowS
showsPrec :: SettingsValue -> FileSpec -> ShowS
$cshow :: FileSpec -> String
show :: FileSpec -> String
$cshowList :: [FileSpec] -> ShowS
showList :: [FileSpec] -> ShowS
Show)

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

{-

== Stream state

The stream state is stored in the 'streamState' field (an @IORef@) of a
'Stream'. The main place where the stream state is updated is in
'controlOrStream', which does something like this:

> state0 <- readStreamState strm
> state1 <- stream .. state0 ..
> processState .. state1 ..

where 'processState' updates the @IORef@, based on 'state1' (the state computed
by 'stream') and the /current/ state of the stream; for simplicity, we will
assume here that this must equal 'state0' (it might not, if a concurrent thread
changed the stream state).

The diagram below summarizes the stream state transitions on the client side,
omitting error cases (which result in exceptions being thrown). Each transition
is labelled with the relevant case in either the function 'stream' or the
function 'processState'.

>                        [Open JustOpened]
>                               |
>                               |
>                            HEADERS
>                               |
>                               | (stream1)
>                               |
>                          END_HEADERS?
>                               |
>                        ______/ \______
>                       /   yes   no    \
>                      |                |
>                      |         [Open Continued] <--\
>                      |                |            |
>                      |           CONTINUATION      |
>                      |                |            |
>                      |                | (stream5)  |
>                      |                |            |
>                      |           END_HEADERS?      |
>                      |                |            |
>                      v           yes / \ no        |
>                 END_STREAM? <-------/   \-----------/
>                      |                   (process3)
>                      |
>            _________/ \_________
>           /      yes   no       \
>           |                     |
>      [Open NoBody]        [Open HasBody]
>           |                     |
>           | (process1)          | (process2)
>           |                     |
>  [HalfClosedRemote] <--\   [Open Body] <----------------------\
>           |             |        |                             |
>           |             |        +---------------\             |
>       RST_STREAM        |        |               |             |
>           |             |     HEADERS           DATA           |
>           | (stream6)   |        |               |             |
>           |             |        | (stream2)     | (stream4)   |
>           | (process5)  |        |               |             |
>           |             |   END_STREAM?      END_STREAM?       |
>        [Closed]         |        |               |             |
>                         |        | yes      yes / \ no         |
>                         \--------+-------------/   \-----------/
>                          (process4)                 (process6)

Notes:

- The 'HalfClosedLocal' state is not used on the client side.
- Indeed, unless an exception is thrown, even the 'Closed' stream state is not
  used in the client; when the @IORef@ is collected, it is typically in
  'HalfClosedRemote' state.

-}

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
(SettingsValue -> ClosedCode -> ShowS)
-> (ClosedCode -> String)
-> ([ClosedCode] -> ShowS)
-> Show ClosedCode
forall a.
(SettingsValue -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: SettingsValue -> ClosedCode -> ShowS
showsPrec :: SettingsValue -> ClosedCode -> ShowS
$cshow :: ClosedCode -> String
show :: ClosedCode -> String
$cshowList :: [ClosedCode] -> ShowS
showList :: [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: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ClosedCode -> String
forall a. Show a => a -> String
show ClosedCode
e
    show (Closed ClosedCode
e)          = String
"Closed: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ClosedCode -> String
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 = SettingsValue -> String
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      -- payload length
                 Bool             -- require flushing
                 (Maybe DynaNext)

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

data Control = CFinish    HTTP2Error
             | CFrames (Maybe SettingsList) [ByteString]

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

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 ReasonPhrase
  | BadThingHappen E.SomeException
  deriving (SettingsValue -> HTTP2Error -> ShowS
[HTTP2Error] -> ShowS
HTTP2Error -> String
(SettingsValue -> HTTP2Error -> ShowS)
-> (HTTP2Error -> String)
-> ([HTTP2Error] -> ShowS)
-> Show HTTP2Error
forall a.
(SettingsValue -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: SettingsValue -> HTTP2Error -> ShowS
showsPrec :: SettingsValue -> HTTP2Error -> ShowS
$cshow :: HTTP2Error -> String
show :: HTTP2Error -> String
$cshowList :: [HTTP2Error] -> ShowS
showList :: [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 ((SettingsKey, SettingsValue) -> Maybe HTTP2Error)
-> SettingsList -> [HTTP2Error]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (SettingsKey, SettingsValue) -> Maybe HTTP2Error
checkSettingsValue SettingsList
settings of
    []    -> Maybe HTTP2Error
forall a. Maybe a
Nothing
    (HTTP2Error
x:[HTTP2Error]
_) -> HTTP2Error -> Maybe 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 SettingsValue -> SettingsValue -> Bool
forall a. Eq a => a -> a -> Bool
/= SettingsValue
0 Bool -> Bool -> Bool
&& SettingsValue
v SettingsValue -> SettingsValue -> Bool
forall a. Eq a => a -> a -> Bool
/= SettingsValue
1 = HTTP2Error -> Maybe HTTP2Error
forall a. a -> Maybe a
Just (HTTP2Error -> Maybe HTTP2Error) -> HTTP2Error -> Maybe HTTP2Error
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 SettingsValue -> SettingsValue -> Bool
forall a. Ord a => a -> a -> Bool
> SettingsValue
maxWindowSize = HTTP2Error -> Maybe HTTP2Error
forall a. a -> Maybe a
Just (HTTP2Error -> Maybe HTTP2Error) -> HTTP2Error -> Maybe HTTP2Error
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 SettingsValue -> SettingsValue -> Bool
forall a. Ord a => a -> a -> Bool
< SettingsValue
defaultPayloadLength Bool -> Bool -> Bool
|| SettingsValue
v SettingsValue -> SettingsValue -> Bool
forall a. Ord a => a -> a -> Bool
> SettingsValue
maxPayloadLength = HTTP2Error -> Maybe HTTP2Error
forall a. a -> Maybe a
Just (HTTP2Error -> Maybe HTTP2Error) -> HTTP2Error -> Maybe HTTP2Error
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)
_ = Maybe HTTP2Error
forall a. Maybe a
Nothing