diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 ------- diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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. diff --git a/hs-src/SecondTransfer/Exception.hs b/hs-src/SecondTransfer/Exception.hs --- a/hs-src/SecondTransfer/Exception.hs +++ b/hs-src/SecondTransfer/Exception.hs @@ -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 diff --git a/hs-src/SecondTransfer/Http2/Session.hs b/hs-src/SecondTransfer/Http2/Session.hs --- a/hs-src/SecondTransfer/Http2/Session.hs +++ b/hs-src/SecondTransfer/Http2/Session.hs @@ -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` diff --git a/hs-src/SecondTransfer/Utils/HTTPHeaders.hs b/hs-src/SecondTransfer/Utils/HTTPHeaders.hs --- a/hs-src/SecondTransfer/Utils/HTTPHeaders.hs +++ b/hs-src/SecondTransfer/Utils/HTTPHeaders.hs @@ -20,6 +20,7 @@ -- doing a set of operations on that representation. -- ,HeaderEditor + ,Headers -- ** Introducing and removing the `HeaderEditor` ,fromList ,toList diff --git a/second-transfer.cabal b/second-transfer.cabal --- a/second-transfer.cabal +++ b/second-transfer.cabal @@ -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 diff --git a/tests/tests-hs-src/SecondTransfer/Test/DecoySession.hs b/tests/tests-hs-src/SecondTransfer/Test/DecoySession.hs --- a/tests/tests-hs-src/SecondTransfer/Test/DecoySession.hs +++ b/tests/tests-hs-src/SecondTransfer/Test/DecoySession.hs @@ -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. diff --git a/tests/tests-hs-src/hunit_tests.hs b/tests/tests-hs-src/hunit_tests.hs --- a/tests/tests-hs-src/hunit_tests.hs +++ b/tests/tests-hs-src/hunit_tests.hs @@ -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 ]