second-transfer 0.5.3.2 → 0.5.4.0

raw patch · 8 files changed

+167/−22 lines, 8 filesdep ~transformers

Dependency ranges changed: transformers

Files

• README.md +9/−0
• changelog.md +4/−1
• hs-src/SecondTransfer/Exception.hs +36/−7
• hs-src/SecondTransfer/Http2/Session.hs +60/−9
• hs-src/SecondTransfer/Utils/HTTPHeaders.hs +1/−0
• second-transfer.cabal +3/−2
• tests/tests-hs-src/SecondTransfer/Test/DecoySession.hs +51/−2
• tests/tests-hs-src/hunit_tests.hs +3/−1

@@ -29,6 +29,15 @@      $ cabal test ++Debugging complicated scenarios+-------------------------------++To access full debugging capabilities, for example from the test suite, use the +following command from the project's directory:++    $ cabal exec -- ghci -ihs-src -itests/tests-hs-src -itests/support -XCPP -Imacros/ dist/build/cbits/tlsinc.o+ Example ------- 

@@ -1,4 +1,7 @@-+- 0.5.4.0 :+    * Added the type HTTP500PrecursorException and corresponding test+    * Improved test suite so that requests can be simulated a little bit more easily+    * Re-export type Headers from module HTTPHeaders  - 0.5.3.2 :      * Added this changelog. 

@@ -9,6 +9,9 @@     ,BadPrefaceException (..)     ,HTTP11Exception (..)     ,HTTP11SyntaxException (..)+    ,HTTP500PrecursorException (..)+    ,convertHTTP500PrecursorExceptionToException+    ,getHTTP500PrecursorExceptionFromException     ,ContentLengthMissingException (..)      -- * Exceptions related to the IO layer@@ -16,6 +19,7 @@     ,GenericIOProblem(..)     ,StreamCancelledException(..) +     -- * Internal exceptions     ,HTTP2ProtocolException(..)     ) where @@ -72,7 +76,6 @@     cast a  - -- | Thrown when the HTTP/2 connection prefix doesn't  --   match the expected prefix. data BadPrefaceException = BadPrefaceException@@ -85,26 +88,54 @@  -- | Abstract exception. All HTTP/1.1 related exceptions derive from here. --   Notice that this includes a lot of logical errors and they can be---   raised when handling HTTP/2 sessions also+--   raised when handling HTTP/2 sessions as well data HTTP11Exception = forall e . Exception e => HTTP11Exception e     deriving Typeable  instance Show HTTP11Exception where     show (HTTP11Exception e) = show e -instance  Exception HTTP11Exception +instance Exception HTTP11Exception  convertHTTP11ExceptionToException :: Exception e => e -> SomeException convertHTTP11ExceptionToException = toException . HTTP11Exception  getHTTP11ExceptionFromException :: Exception e => SomeException -> Maybe e getHTTP11ExceptionFromException x = do-    HTTP2SessionException a <- fromException x+    HTTP11Exception a <- fromException x     cast a +-- | Abstract exception. It is an error if an exception of this type bubbles+--   to this library, but we will do our best to handle it gracefully. +--   All internal error precursors at the workers can thus inherit from here+--   to have a fallback option in case they forget to handle the error.+--   This exception inherits from HTTP11Exception+data HTTP500PrecursorException = forall e . Exception e => HTTP500PrecursorException e+    deriving Typeable++instance Show HTTP500PrecursorException where +    show (HTTP500PrecursorException e) = show e++-- | Use the traditional idiom if you need to derive from 'HTTP500PrecursorException',+--   this is one of the helpers+convertHTTP500PrecursorExceptionToException :: Exception e => e -> SomeException+convertHTTP500PrecursorExceptionToException = toException . HTTP500PrecursorException++-- | Use the traditional idiom if you need to derive from 'HTTP500PrecursorException',+--   this is one of the helpers+getHTTP500PrecursorExceptionFromException :: Exception e => SomeException -> Maybe e+getHTTP500PrecursorExceptionFromException x = do+    HTTP500PrecursorException a <- fromException x+    cast a++-- Here we say how we go with these exceptions.... +instance Exception HTTP500PrecursorException where+    toException = convertHTTP11ExceptionToException+    fromException = getHTTP11ExceptionFromException+ -- | Thrown with HTTP/1.1 over HTTP/1.1 sessions when the response body --   or the request body doesn't include a Content-Length header field,---   even if it should have included it +--   given that should have included it  data ContentLengthMissingException = ContentLengthMissingException      deriving (Typeable, Show) @@ -112,7 +143,6 @@     toException = convertHTTP11ExceptionToException     fromException = getHTTP11ExceptionFromException - data HTTP11SyntaxException = HTTP11SyntaxException String      deriving (Typeable, Show) @@ -124,7 +154,6 @@ --   to have the HTTP/2 session to terminate gracefully.  data IOProblem = forall e . Exception e => IOProblem e      deriving Typeable-  instance  Show IOProblem where     show (IOProblem e) = show e 

@@ -36,6 +36,7 @@ import           Control.Monad                          (forever) import           Control.Monad.IO.Class                 (liftIO) import           Control.Monad.Trans.Reader+-- import           Control.Monad.Catch                    (throwM)  import           Control.Concurrent.MVar import qualified Data.ByteString                        as B@@ -142,9 +143,10 @@ -- Have to figure out which are these...but I would expect to have things -- like unexpected aborts here in this type. data SessionInputCommand = -    FirstFrame_SIC InputFrame -- This frame is special-    |MiddleFrame_SIC InputFrame -- Ordinary frame-    |CancelSession_SIC+    FirstFrame_SIC InputFrame       -- This frame is special+    |MiddleFrame_SIC InputFrame     -- Ordinary frame+    |InternalAbort_SIC              -- Internal abort from the session itself+    |CancelSession_SIC              -- Cancel request from the framer   deriving Show   @@ -366,7 +368,9 @@          CancelSession_SIC -> do              -- Good place to tear down worker threads... Let the rest of the finalization-            -- to the framer+            -- to the framer.+            --+            -- This message is normally got from the Framer             liftIO $ do                  H.mapM_                     (\ (_, thread_id) -> do@@ -378,6 +382,12 @@             -- We do not continue here, but instead let it finish             return () +        InternalAbort_SIC -> do +            -- Message triggered because the worker failed to behave. +            -- When this is sent, the connection is closed +            closeConnectionBecauseIsInvalid NH2.InternalError +            return ()+         -- The block below will process both HEADERS and CONTINUATION frames.          -- TODO: As it stands now, the server will happily start a new stream with          -- a CONTINUATION frame instead of a HEADERS frame. That's against the @@ -466,10 +476,25 @@                 -- even if the method doesn't allow for data.                  -- I'm clear to start the worker, in its own thread+                -- +                -- NOTE: Some late internal errors from the worker thread are +                --       handled here by clossing the session.+                --+                -- TODO: Log exceptions handled here.                 liftIO $ do -                    thread_id <- forkIO $ runReaderT -                        (workerThread (header_list_after, post_data_source) coherent_worker)-                        for_worker_thread +                    thread_id <- forkIO $ E.catch +                        (runReaderT +                            (workerThread (header_list_after, post_data_source) coherent_worker)+                            for_worker_thread +                        )+                        ( +                            (   \ _ ->  do +                                -- Actions to take when the thread breaks....+                                writeChan session_input InternalAbort_SIC+                            ) +                            :: HTTP500PrecursorException -> IO () +                        )+                     H.insert stream2workerthread stream_id thread_id                  return ()@@ -786,7 +811,21 @@     return $ NS.member stream_id cancelled_streams  +sendPrimitive500Error :: IO PrincipalStream+sendPrimitive500Error = +  return (+        [+            (":status", "500")+        ],+        [],+        do +            yield "Internal server error\n"+            -- No footers+            return []+    ) ++ workerThread :: Request -> CoherentWorker -> WorkerMonad () workerThread req coherent_worker =   do@@ -797,14 +836,24 @@     --       throws an exception signaling that the request is ill-formed     --       and should be dropped? That could happen in a couple of occassions,     --       but really most cases should be handled here in this file...-    (headers, _, data_and_conclussion) <- liftIO $ coherent_worker req+    (headers, _, data_and_conclussion) <- +        liftIO $ E.catch +            ( do +                (h, x, d) <- coherent_worker req +                return $! (h,x,d)+            )+            ( +                (\ _ -> sendPrimitive500Error ) +                :: HTTP500PrecursorException -> IO (Headers, PushedStreams, DataAndConclusion) +            )      -- Now I send the headers, if that's possible at all     headers_sent <- liftIO $ newEmptyMVar     liftIO $ writeChan headers_output (stream_id, headers_sent, headers)      -- At this moment I should ask if the stream hasn't been cancelled by the browser before-    -- commiting to the work of sending addtitional data+    -- commiting to the work of sending addtitional data... this is important for pushed +    -- streams     is_stream_cancelled <- isStreamCancelled stream_id     if not is_stream_cancelled @@ -814,6 +863,8 @@         -- liftIO ( data_and_conclussion $$ (_sendDataOfStream stream_id) )         --          -- This threadlet should block here waiting for the headers to finish going+        -- NOTE: Exceptions generated here inheriting from HTTP500PrecursorException +        -- are let to bubble and managed in this thread fork point...         (_maybe_footers, _) <- runConduit $             (transPipe liftIO data_and_conclussion)              `fuseBothMaybe` 

@@ -20,6 +20,7 @@     --   doing a set of operations on that representation.     --     ,HeaderEditor+    ,Headers     -- ** Introducing and removing the `HeaderEditor`     ,fromList      ,toList 

@@ -7,7 +7,7 @@ -- PVP       summary:      +-+------- breaking API changes --                         | | +----- non-breaking API additions --                         | | | +--- code changes with no API change-version     :              0.5.3.2+version     :              0.5.4.0  synopsis    :              Second Transfer HTTP/2 web server @@ -53,7 +53,7 @@ source-repository this   type:     git   location: git@github.com:alcidesv/second-transfer.git-  tag:      0.5.3.2+  tag:      0.5.4.0  library @@ -183,5 +183,6 @@                     ,HUnit >= 1.2 && < 1.5                     ,bytestring >= 0.10.4.0                     ,http2 == 0.9.1+                    ,transformers >= 0.3   ghc-options     : -threaded   other-modules   : SecondTransfer.Test.DecoySession

@@ -12,6 +12,7 @@ import qualified Control.Lens            as L  import qualified Network.HTTP2           as NH2+import qualified Network.HPACK           as HP  import qualified Data.ByteString         as B  import qualified Data.ByteString.Lazy    as LB@@ -29,6 +30,8 @@     ,_nh2Settings       :: NH2.Settings     ,_sessionThrowed    :: MVar Bool     ,_waiting           :: MVar ThreadId +    ,_encodeHeadersHere :: MVar HP.DynamicTable+    ,_decodeHeadersHere :: MVar HP.DynamicTable     }  @@ -49,6 +52,10 @@         close_action = do             return () +    dtable_for_encoding <- HP.newDynamicTableForEncoding 4096+    dtable_for_encoding_mvar <- newMVar dtable_for_encoding+    dtable_for_decoding <- HP.newDynamicTableForDecoding 4096+    dtable_for_decoding_mvar <- newMVar dtable_for_decoding      waiting_mvar <- newEmptyMVar         @@ -71,8 +78,9 @@         _sessionThread     = thread_id,         _remainingOutputBit= remaining_output_bit,         _nh2Settings       = NH2.defaultSettings,-        _waiting           = waiting_mvar-+        _waiting           = waiting_mvar,+        _encodeHeadersHere = dtable_for_encoding_mvar,+        _decodeHeadersHere = dtable_for_decoding_mvar         }     return session @@ -116,6 +124,30 @@         Right  frame  -> return $ Just frame  +-- Encode headers to send to the session +-- TODO: There is an important bug here... we are using the default encoding+-- strategy everywhere+encodeHeadersForSession :: DecoySession -> Headers -> IO B.ByteString+encodeHeadersForSession decoy_session headers = +  do +    let +        mv = (decoy_session ^. encodeHeadersHere )+    dtable <- takeMVar mv+    (dtable', bs ) <- HP.encodeHeader HP.defaultEncodeStrategy dtable headers +    putMVar mv dtable'+    return bs++-- Decode headers to receive them from the session +decodeHeadersForSession :: DecoySession -> B.ByteString -> IO Headers +decodeHeadersForSession decoy_session bs = +  do +    let +        mv = (decoy_session ^. decodeHeadersHere )+    dtable <- takeMVar mv +    (dtable', headers) <- HP.decodeHeader dtable bs+    putMVar mv dtable'+    return headers+ -- Send raw data to a session  sendRawDataToSession :: DecoySession -> B.ByteString -> IO () sendRawDataToSession decoy_session data_to_send = do@@ -128,6 +160,23 @@     writeChan input_data_channel data_to_send     takeMVar waiting_for_write     return ()+++-- Send a headers frame to the session that ends the stream...+performRequestSimple :: DecoySession -> Int -> Headers -> IO ()+performRequestSimple decoy_session stream_id headers = do +    headers_data <- encodeHeadersForSession decoy_session headers +    let +        frame = NH2.HeadersFrame +            Nothing  -- No priority+            headers_data +        frame_data_ei = NH2.EncodeInfo {+            NH2.encodeFlags = NH2.setEndStream . NH2.setEndHeader $ NH2.defaultFlags,+            NH2.encodeStreamId = NH2.toStreamIdentifier stream_id,+            NH2.encodePadding = Nothing+            }+    +    sendFrameToSession decoy_session (frame_data_ei,frame)   -- Read raw data from a session. Normally blocks until data be available.

@@ -23,7 +23,9 @@     TestLabel "testReplaceHostByAuthority" testReplaceHostByAuthority,     TestLabel "testFirstFrameIsSettings" testFirstFrameMustBeSettings,     TestLabel "testFirstFrameIsSettings2" testFirstFrameMustBeSettings2,-    TestLabel "testFirstFrameIsSettings3" testFirstFrameMustBeSettings3+    TestLabel "testFirstFrameIsSettings3" testFirstFrameMustBeSettings3,+    TestLabel "testIGet500Status" testIGet500Status,+    TestLabel "testSessionBreaksOnLateError" testSessionBreaksOnLateError     ]