File: Types.hs

package info (click to toggle)
haskell-http2 5.0.1-1
  • links: PTS, VCS
  • area: main
  • in suites: forky, sid, trixie
  • size: 55,180 kB
  • sloc: haskell: 8,657; makefile: 5
file content (396 lines) | stat: -rw-r--r-- 13,618 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}

module Network.HTTP2.H2.Types where

import qualified Control.Exception as E
import Data.ByteString.Builder (Builder)
import Data.IORef
import Data.Typeable
import Network.Control
import qualified Network.HTTP.Types as H
import Network.Socket hiding (Stream)
import System.IO.Unsafe
import qualified System.TimeManager as T
import UnliftIO.Concurrent
import UnliftIO.Exception (SomeException)
import UnliftIO.STM

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

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

-- | "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 ())
    | -- | Like 'OutBodyStreaming', but with a callback to unmask expections
      --
      -- This is used in the client: we spawn the new thread for the request body
      -- with exceptions masked, and provide the body of 'OutBodyStreamingUnmask'
      -- with a callback to unmask them again (typically after installing an exception
      -- handler).
      --
      -- We do /NOT/ support this in the server, as here the scope of the thread
      -- that is spawned for the server is the entire handler, not just the response
      -- streaming body.
      --
      -- TODO: The analogous change for the server-side would be to provide a similar
      -- @unmask@ callback as the first argument in the 'Server' type alias.
      OutBodyStreamingUnmask
        ((forall x. IO x -> IO x) -> (Builder -> IO ()) -> IO () -> IO ())
    | OutBodyBuilder Builder
    | OutBodyFile FileSpec

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

instance Show InpObj where
    show (InpObj (thl, _) _ _body _tref) = show thl

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

instance Show OutObj where
    show (OutObj hdr _ _) = show 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 Nothing = return $ Trailers []
defaultTrailersMaker _ = return $ NextTrailersMaker 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 (Eq, 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 (Either SomeException 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 (Show)

closedCodeToError :: StreamId -> ClosedCode -> HTTP2Error
closedCodeToError sid cc =
    case cc of
        Finished -> ConnectionIsClosed
        Killed -> ConnectionIsTimeout
        Reset err -> ConnectionErrorIsReceived err sid "Connection was reset"
        ResetByMe err -> BadThingHappen err

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

data StreamState
    = Idle
    | Open (Maybe ClosedCode) OpenState -- HalfClosedLocal if Just
    | HalfClosedRemote
    | Closed ClosedCode
    | Reserved

instance Show StreamState where
    show Idle = "Idle"
    show (Open Nothing _) = "Open"
    show (Open (Just e) _) = "HalfClosedLocal: " ++ show e
    show HalfClosedRemote = "HalfClosedRemote"
    show (Closed e) = "Closed: " ++ show e
    show Reserved = "Reserved"

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

data Stream = Stream
    { streamNumber :: StreamId
    , streamState :: IORef StreamState
    , streamInput :: MVar (Either SomeException InpObj) -- Client only
    , streamTxFlow :: TVar TxFlow
    , streamRxFlow :: IORef RxFlow
    }

instance Show Stream where
    show Stream{..} =
        "Stream{id="
            ++ show streamNumber
            ++ ",state="
            ++ show (unsafePerformIO (readIORef streamState))
            ++ "}"

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

data Input a = Input a InpObj

data Output a = Output
    { outputStream :: a
    , outputObject :: OutObj
    , outputType :: OutputType
    , outputStrmQ :: Maybe (TBQueue StreamingChunk)
    , 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]
    | CGoaway ByteString (MVar ())

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

data StreamingChunk
    = StreamingFinished (IO ())
    | 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
    | ConnectionIsTimeout
    | ConnectionErrorIsReceived ErrorCode StreamId ReasonPhrase
    | ConnectionErrorIsSent ErrorCode StreamId ReasonPhrase
    | StreamErrorIsReceived ErrorCode StreamId
    | StreamErrorIsSent ErrorCode StreamId ReasonPhrase
    | BadThingHappen E.SomeException
    | GoAwayIsSent
    deriving (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 settings = case mapMaybe checkSettingsValue settings of
    [] -> Nothing
    (x : _) -> Just x

checkSettingsValue :: (SettingsKey, SettingsValue) -> Maybe HTTP2Error
checkSettingsValue (SettingsEnablePush, v)
    | v /= 0 && v /= 1 =
        Just $ ConnectionErrorIsSent ProtocolError 0 "enable push must be 0 or 1"
checkSettingsValue (SettingsInitialWindowSize, v)
    | v > maxWindowSize =
        Just $
            ConnectionErrorIsSent
                FlowControlError
                0
                "Window size must be less than or equal to 65535"
checkSettingsValue (SettingsMaxFrameSize, v)
    | v < defaultPayloadLength || v > maxPayloadLength =
        Just $
            ConnectionErrorIsSent
                ProtocolError
                0
                "Max frame size must be in between 16384 and 16777215"
checkSettingsValue _ = Nothing

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

-- | HTTP/2 configuration.
data Config = Config
    { confWriteBuffer :: Buffer
    -- ^ This is used only by frameSender.
    -- This MUST be freed after frameSender is terminated.
    , confBufferSize :: BufferSize
    -- ^ The size of the write buffer.
    --   We assume that the read buffer is the same size.
    --   So, this value is announced via SETTINGS_MAX_FRAME_SIZE
    --   to the peer.
    , confSendAll :: ByteString -> IO ()
    , confReadN :: Int -> IO ByteString
    , confPositionReadMaker :: PositionReadMaker
    , confTimeoutManager :: T.Manager
    , confMySockAddr :: SockAddr
    -- ^ This is copied into 'Aux', if exist, on server.
    , confPeerSockAddr :: SockAddr
    -- ^ This is copied into 'Aux', if exist, on server.
    }