packages feed

second-transfer 0.5.3.1 → 0.5.3.2

raw patch · 9 files changed

+163/−73 lines, 9 filesdep ~time

Dependency ranges changed: time

Files

+ changelog.md view
@@ -0,0 +1,7 @@+++- 0.5.3.2 : +    * Added this changelog. +    * Fixed the lower limit for the time package.+    * Enforce first frame being a settings frame when receiving.+    * Added a couple of tests.
hs-src/SecondTransfer/Http2/Framer.hs view
@@ -44,7 +44,7 @@                                                          PullAction, PushAction) import           SecondTransfer.Utils                   (Word24, word24ToInt) import           SecondTransfer.Exception-+import           SecondTransfer.MainLoop.Logging        (logWithExclusivity)  #include "Logging.cpphs" @@ -161,11 +161,11 @@         exc_handler :: Int -> SessionsContext -> FramerException -> IO ()         exc_handler x y e = do             modifyMVar_ output_is_forbidden (\ _ -> return True) -            errorM "HTTP2.Framer" "Exception went up"+            INSTRUMENTATION( errorM "HTTP2.Framer" "Exception went up" )             sessionExceptionHandler Framer_HTTP2SessionComponent x y e          io_exc_handler :: Int -> SessionsContext -> IOProblem -> IO ()-        io_exc_handler x y e = do+        io_exc_handler _x _y _e = do             modifyMVar_ output_is_forbidden (\ _ -> return True)              -- !!! These exceptions are way too common for we to care....             -- errorM "HTTP2.Framer" "Exception went up"@@ -183,12 +183,13 @@   http2FrameLength :: F.LengthCallback-http2FrameLength bs | (B.length bs) >= 3     = let-    word24 = decode input_as_lbs :: Word24-    input_as_lbs = LB.fromStrict bs-  in -    Just $ (word24ToInt word24) + 9 -- Nine bytes that the frame header always uses-http2FrameLength _ = Nothing+http2FrameLength bs +    | (B.length bs) >= 3     = let+        word24 = decode input_as_lbs :: Word24+        input_as_lbs = LB.fromStrict bs+      in +        Just $ (word24ToInt word24) + 9 -- Nine bytes that the frame header always uses+    | otherwise = Nothing   addCapacity :: @@ -236,20 +237,27 @@         liftIO $ do              -- We just the the GoAway frame, although this is awfully early             -- and probably wrong-            INSTRUMENTATION( errorM "HTTP2.Framer" "Invalid prologue")             throwIO BadPrefaceException       else -        INSTRUMENTATION( liftIO $ debugM "HTTP2.Framer" "Prologue validated" )+        INSTRUMENTATION(  debugM "HTTP2.Framer" "Prologue validated" )     let          source::Source FramerSession B.ByteString         source = transPipe liftIO $ F.readNextChunk http2FrameLength remaining pull_action-    ( source $$ consume)+    ( source $$ consume True)   where  -    consume :: Sink B.ByteString FramerSession ()-    consume = do +    sendToSession :: Bool -> InputFrame -> IO ()+    sendToSession starting frame = if starting +      then do+        sendFirstFrameToSession session_input frame +      else do+        sendMiddleFrameToSession session_input frame++    consume_continue = consume False++    consume :: Bool -> Sink B.ByteString FramerSession ()+    consume starting = do          maybe_bytes <- await -        -- Deserialize          case maybe_bytes of  @@ -265,7 +273,7 @@                         -- Got an error from the decoder... meaning that a frame could                          -- not be decoded.... in this case we send a cancel session command                          -- to the session. -                        liftIO $ errorM "HTTP2.Framer" "CouldNotDecodeFrame"+                        INSTRUMENTATION( errorM "HTTP2.Framer" "CouldNotDecodeFrame" )                         -- Send frames like GoAway and such...                         lift $ sendGoAwayFrame NH2.ProtocolError                         -- Inform the session that it can tear down itself@@ -312,7 +320,7 @@                                  -- And send the frame down to the session, so that session specific settings                                 -- can be applied. -                                liftIO $ sendFrameToSession session_input frame+                                liftIO $ sendToSession starting frame                               a_frame@(NH2.Frame (NH2.FrameHeader _ _ stream_id) _ )   -> do @@ -320,9 +328,10 @@                                 lift $ updateLastStream $ NH2.fromStreamIdentifier stream_id                                  -- Send frame to the session-                                liftIO $ sendFrameToSession session_input a_frame+                                liftIO $ sendToSession starting a_frame+                         -- tail recursion: go again...-                        consume +                        consume_continue              Nothing    ->                  -- We may as well exit this thread@@ -348,14 +357,12 @@      loopPart :: FramerSession ()     loopPart = do -         command_or_frame  <- liftIO $ getFrameFromSession session_output-         case command_or_frame of               Left CancelSession_SOC -> do                  -- The session wants to cancel things-                INSTRUMENTATION( liftIO $ debugM "HTTP2.Framer" "CancelSession_SOC processed")+                INSTRUMENTATION(  debugM "HTTP2.Framer" "CancelSession_SOC processed")                 releaseFramer              Right ( p1@(NH2.EncodeInfo _ stream_idii _), p2@(NH2.DataFrame _) ) -> do
hs-src/SecondTransfer/Http2/Session.hs view
@@ -6,7 +6,8 @@ module SecondTransfer.Http2.Session(     http2Session     ,getFrameFromSession-    ,sendFrameToSession+    ,sendFirstFrameToSession+    ,sendMiddleFrameToSession     ,sendCommandToSession      ,CoherentSession@@ -65,6 +66,7 @@ import           SecondTransfer.Utils                   (unfoldChannelAndSource) import           SecondTransfer.Exception import qualified SecondTransfer.Utils.HTTPHeaders       as He+import           SecondTransfer.MainLoop.Logging        (logWithExclusivity)  -- Unfortunately the frame encoding API of Network.HTTP2 is a bit difficult to  -- use :-( @@ -112,12 +114,15 @@  -- From outside, one can only write to this one ... the newtype is to enforce  --    this.-newtype SessionInput = SessionInput ( Chan (Either SessionInputCommand InputFrame) )-sendFrameToSession :: SessionInput  -> InputFrame -> IO ()-sendFrameToSession (SessionInput chan) frame = writeChan chan $ Right frame+newtype SessionInput = SessionInput ( Chan SessionInputCommand )+sendMiddleFrameToSession :: SessionInput  -> InputFrame -> IO ()+sendMiddleFrameToSession (SessionInput chan) frame = writeChan chan $ MiddleFrame_SIC frame +sendFirstFrameToSession :: SessionInput -> InputFrame -> IO ()+sendFirstFrameToSession (SessionInput chan) frame = writeChan chan $ FirstFrame_SIC frame+ sendCommandToSession :: SessionInput  -> SessionInputCommand -> IO ()-sendCommandToSession (SessionInput chan) command = writeChan chan $ Left command+sendCommandToSession (SessionInput chan) command = writeChan chan command  -- From outside, one can only read from this one  newtype SessionOutput = SessionOutput ( Chan (Either SessionOutputCommand OutputFrame) )@@ -137,7 +142,9 @@ -- Have to figure out which are these...but I would expect to have things -- like unexpected aborts here in this type. data SessionInputCommand = -    CancelSession_SIC+    FirstFrame_SIC InputFrame -- This frame is special+    |MiddleFrame_SIC InputFrame -- Ordinary frame+    |CancelSession_SIC   deriving Show   @@ -170,7 +177,7 @@     -- ATTENTION: Ignore the warning coming from here for now     _sessionsContext             :: SessionsContext  -    ,_sessionInput               :: Chan (Either SessionInputCommand InputFrame)+    ,_sessionInput               :: Chan SessionInputCommand      -- We need to lock this channel occassionally so that we can order multiple      -- header frames properly.... @@ -265,7 +272,7 @@      let session_data  = SessionData {         _sessionsContext             = sessions_context-        ,_sessionInput                = session_input +        ,_sessionInput               = session_input          ,_sessionOutput              = session_output_mvar         ,_toDecodeHeaders            = decode_headers_table_mvar         ,_toEncodeHeaders            = encode_headers_table_mvar@@ -316,7 +323,7 @@ --- more robust. sessionInputThread :: ReaderT SessionData IO () sessionInputThread  = do -    INSTRUMENTATION( liftIO $ debugM "HTTP2.Session" "Entering sessionInputThread" )+    INSTRUMENTATION( debugM "HTTP2.Session" "Entering sessionInputThread" )      -- This is an introductory and declarative block... all of this is tail-executed     -- every time that  a packet needs to be processed. It may be a good idea to abstract@@ -335,11 +342,29 @@      input                     <- liftIO $ readChan session_input -    -- INSTRUMENTATION( liftIO $ infoM "HTTP2.Session" $ "Got a frame or a command: " ++ (show input) )-     case input of  -        Left CancelSession_SIC -> do +        FirstFrame_SIC (NH2.Frame +            (NH2.FrameHeader _ 1 null_stream_id ) _ )| NH2.toStreamIdentifier 0 == null_stream_id  -> do +            -- This is a SETTINGS ACK frame, which is okej to have,+            -- do nothing here+            continue ++        FirstFrame_SIC +            (NH2.Frame +                (NH2.FrameHeader _ 0 null_stream_id ) +                (NH2.SettingsFrame settings_list) +            ) | NH2.toStreamIdentifier 0 == null_stream_id  -> do +            -- Good, handle +            handleSettingsFrame settings_list+            continue ++        FirstFrame_SIC _ -> do +            -- Bad, incorrect id or god knows only what .... +            closeConnectionBecauseIsInvalid NH2.ProtocolError+            return ()++        CancelSession_SIC -> do              -- Good place to tear down worker threads... Let the rest of the finalization             -- to the framer             liftIO $ do @@ -357,7 +382,7 @@         -- 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          -- protocol.-        Right frame | Just (stream_id, bytes) <- isAboutHeaders frame -> do +        MiddleFrame_SIC frame | Just (stream_id, bytes) <- isAboutHeaders frame -> do              -- Just append the frames to streamRequestHeaders             opens_stream <- appendHeaderFragmentBlock stream_id bytes @@ -366,7 +391,6 @@                 maybe_rcv_headers_of <- liftIO $ takeMVar receiving_headers_mvar                 case maybe_rcv_headers_of of                    Just _ -> do -                    -- INSTRUMENTATION( liftIO $ errorM "HTTP2.Session" "headers being received")                     -- Bad client, it is already sending headers                      -- and trying to open another one                     closeConnectionBecauseIsInvalid NH2.ProtocolError@@ -383,7 +407,7 @@                         liftIO $ putMVar last_good_stream_mvar (stream_id)                       else do                          -- We are not golden-                        INSTRUMENTATION( liftIO $ errorM "HTTP2.Session" "Protocol error: bad stream id")+                        INSTRUMENTATION( errorM "HTTP2.Session" "Protocol error: bad stream id")                         closeConnectionBecauseIsInvalid NH2.ProtocolError               else do                  maybe_rcv_headers_of <- liftIO $ takeMVar receiving_headers_mvar@@ -456,7 +480,7 @@                              continue  -        Right frame@(NH2.Frame _ (NH2.RSTStreamFrame _error_code_id)) -> do+        MiddleFrame_SIC frame@(NH2.Frame _ (NH2.RSTStreamFrame _error_code_id)) -> do             let stream_id = streamIdFromFrame frame             liftIO $ do                  INSTRUMENTATION( infoM "HTTP2.Session" $ "Stream reset: " ++ (show _error_code_id) )@@ -467,7 +491,7 @@                 case maybe_thread_id  of                      Nothing ->                          -- This is actually more like an internal error, when this -                        -- happend, cancell the session+                        -- happend, cancel the session                         error "InterruptingUnexistentStream"                      Just thread_id -> do@@ -476,7 +500,7 @@              continue  -        Right frame@(NH2.Frame (NH2.FrameHeader _ _ nh2_stream_id) (NH2.DataFrame somebytes)) +        MiddleFrame_SIC frame@(NH2.Frame (NH2.FrameHeader _ _ nh2_stream_id) (NH2.DataFrame somebytes))            -> unlessReceivingHeaders $ do              -- So I got data to process             -- TODO: Handle end of stream@@ -522,13 +546,13 @@              continue  -        Right (NH2.Frame (NH2.FrameHeader _ flags _) (NH2.PingFrame _)) | NH2.testAck flags-> do +        MiddleFrame_SIC (NH2.Frame (NH2.FrameHeader _ flags _) (NH2.PingFrame _)) | NH2.testAck flags-> do              -- Deal with pings: this is an Ack, so do nothing             continue  -        Right (NH2.Frame (NH2.FrameHeader _ _ _) (NH2.PingFrame somebytes))  -> do +        MiddleFrame_SIC (NH2.Frame (NH2.FrameHeader _ _ _) (NH2.PingFrame somebytes))  -> do              -- Deal with pings: NOT an Ack, so answer-            INSTRUMENTATION( liftIO $ debugM "HTTP2.Session" "Ping processed" )+            INSTRUMENTATION( debugM "HTTP2.Session" "Ping processed" )             sendOutFrame                 (NH2.EncodeInfo                     (NH2.setAck NH2.defaultFlags)@@ -539,35 +563,40 @@              continue  -        Right (NH2.Frame frame_header (NH2.SettingsFrame _)) | isSettingsAck frame_header -> do +        MiddleFrame_SIC (NH2.Frame frame_header (NH2.SettingsFrame _)) | isSettingsAck frame_header -> do              -- Frame was received by the peer, do nothing here...             continue           -- TODO: Do something with these settings!!-        Right (NH2.Frame _ (NH2.SettingsFrame settings_list))  -> do -            INSTRUMENTATION( liftIO $ debugM "HTTP2.Session" $ "Received settings: " ++ (show settings_list) )+        MiddleFrame_SIC (NH2.Frame _ (NH2.SettingsFrame settings_list))  -> do +            INSTRUMENTATION( debugM "HTTP2.Session" $ "Received settings: " ++ (show settings_list) )             -- Just acknowledge the frame.... for now -            sendOutFrame -                (NH2.EncodeInfo-                    (NH2.setAck NH2.defaultFlags)-                    (NH2.toStreamIdentifier 0)-                    Nothing )-                (NH2.SettingsFrame [])-+            handleSettingsFrame settings_list             continue  --        Right somethingelse ->  unlessReceivingHeaders $ do +        MiddleFrame_SIC somethingelse ->  unlessReceivingHeaders $ do              -- An undhandled case here....-            INSTRUMENTATION( liftIO $ errorM "HTTP2.Session" $  "Received problematic frame: " )-            liftIO $ errorM "HTTP2.Session" $  "..  " ++ (show somethingelse)+            INSTRUMENTATION( errorM "HTTP2.Session" $  "Received problematic frame: " )+            INSTRUMENTATION( errorM "HTTP2.Session" $  "..  " ++ (show somethingelse) )              continue     where      continue = sessionInputThread +    -- TODO: Do use the settings!!!+    handleSettingsFrame :: NH2.SettingsList -> ReaderT SessionData IO ()+    handleSettingsFrame _settings_list = +        sendOutFrame +            (NH2.EncodeInfo+                (NH2.setAck NH2.defaultFlags)+                (NH2.toStreamIdentifier 0)+                Nothing )+            (NH2.SettingsFrame []) +++ sendOutFrame :: NH2.EncodeInfo -> NH2.FramePayload -> ReaderT SessionData IO () sendOutFrame encode_info payload = do      session_output_mvar <- view sessionOutput @@ -635,7 +664,7 @@ -- thread of the session.  closeConnectionBecauseIsInvalid :: NH2.ErrorCodeId -> ReaderT SessionData IO a closeConnectionBecauseIsInvalid error_code = do -    liftIO $ errorM "HTTP2.Session" "closeConnectionBecauseIsInvalid called!"+    -- liftIO $ errorM "HTTP2.Session" "closeConnectionBecauseIsInvalid called!"     last_good_stream_mvar <- view lastGoodStream     last_good_stream <- liftIO $ takeMVar last_good_stream_mvar     session_output_mvar <- view sessionOutput @@ -785,7 +814,7 @@         -- liftIO ( data_and_conclussion $$ (_sendDataOfStream stream_id) )         --          -- This threadlet should block here waiting for the headers to finish going-        (maybe_footers, _) <- runConduit $+        (_maybe_footers, _) <- runConduit $             (transPipe liftIO data_and_conclussion)              `fuseBothMaybe`              (sendDataOfStream stream_id headers_sent)@@ -823,7 +852,6 @@          Nothing -> do             -- TODO: Make the commented message below more informative-            -- INSTRUMENTATION( liftIO $ debugM "HTTP2.Session" $ "Starting stream " ++ (show global_stream_id) )             return $ (Bu.byteString bytes, True)          Just something ->
hs-src/SecondTransfer/MainLoop/Framer.hs view
@@ -11,12 +11,13 @@  import           Control.Monad.Trans.Class (lift) import           Control.Monad.IO.Class    (MonadIO-                                           -- , liftIO+                                            -- , liftIO                                            ) import qualified Data.ByteString           as B import qualified Data.ByteString.Builder   as Bu import qualified Data.ByteString.Lazy      as LB import           Data.Conduit+-- import           Debug.Trace               (trace)  #ifndef IMPLICIT_MONOID import           Data.Monoid
hs-src/SecondTransfer/MainLoop/Logging.hs view
@@ -2,6 +2,7 @@ module SecondTransfer.MainLoop.Logging (     -- | Simple, no fuss enable logging     enableConsoleLogging+    ,logWithExclusivity     ) where  import           System.IO                 (stderr)@@ -13,11 +14,27 @@ import           System.Log.Handler.Simple -- import           System.Log.Handler.Syslog (Facility (..), Option (..), openlog) import           System.Log.Logger+import           System.IO.Unsafe          (unsafePerformIO) +import           Control.Concurrent.MVar  + -- | Activates logging to terminal enableConsoleLogging :: IO () enableConsoleLogging = configureLoggingToConsole+++-- | Protect logging with a mutex... that is to say,+--   this is a horrible hack and you should try to log+--   as little as possible or nothing at all. This just +--   works for instrumentation locks...+globallyLogWell :: MVar ()+{-# NOINLINE globallyLogWell #-}+globallyLogWell = unsafePerformIO (newMVar () )++-- | Used internally to avoid garbled logs+logWithExclusivity :: IO () -> IO ()+logWithExclusivity a = withMVar globallyLogWell (\_ -> a )   configureLoggingToConsole :: IO ()
macros/Logging.cpphs view
@@ -2,7 +2,7 @@  #ifdef ENABLE_DEBUG -#define INSTRUMENTATION(x)   (x)+#define INSTRUMENTATION(x)   (liftIO $ logWithExclusivity (x))  #else
second-transfer.cabal view
@@ -7,7 +7,7 @@ -- PVP       summary:      +-+------- breaking API changes --                         | | +----- non-breaking API additions --                         | | | +--- code changes with no API change-version     :              0.5.3.1+version     :              0.5.3.2  synopsis    :              Second Transfer HTTP/2 web server @@ -35,7 +35,7 @@  -- Extra files to be distributed with the package-- such as examples or a  -- README.-extra-source-files:  README.md+extra-source-files:  README.md changelog.md  -- Constraint on the version of Cabal needed to build this package. cabal-version:       >=1.10@@ -53,7 +53,7 @@ source-repository this   type:     git   location: git@github.com:alcidesv/second-transfer.git-  tag:      0.5.3.1+  tag:      0.5.3.2  library @@ -125,7 +125,7 @@                  hslogger >= 1.2.6,                  hashable >= 1.2,                  attoparsec >= 0.12,-                 time >= 1.4.0+                 time >= 1.5.0 && < 1.8      -- Directories containing source files.   hs-source-dirs: hs-src
tests/tests-hs-src/SecondTransfer/Test/DecoySession.hs view
@@ -28,6 +28,7 @@     ,_remainingOutputBit:: MVar B.ByteString     ,_nh2Settings       :: NH2.Settings     ,_sessionThrowed    :: MVar Bool+    ,_waiting           :: MVar ThreadId      }  @@ -40,16 +41,28 @@     input_data_channel  <- newChan      output_data_channel <- newChan     let -        push_action :: PushAction+        push_action  :: PushAction         push_action = writeChan output_data_channel-        pull_action :: PullAction +        pull_action  :: PullAction          pull_action = readChan input_data_channel         close_action :: CloseAction          close_action = do             return ()+++    waiting_mvar <- newEmptyMVar         -    thread_id <- forkIO $ do -        attendant push_action pull_action close_action+    thread_id <- forkIO $ catch +        (do +            attendant push_action pull_action close_action+        )+        ((\ e -> do +            putStrLn $ "Exception: " ++ (show e)+            maybe_waiting <- tryTakeMVar waiting_mvar+            case maybe_waiting of +                Just thread_id -> throwTo thread_id e+                Nothing -> return ()+        ):: SomeException -> IO ())      remaining_output_bit <- newMVar ""     let session = DecoySession {@@ -57,12 +70,14 @@         _outputDataChannel = output_data_channel,         _sessionThread     = thread_id,         _remainingOutputBit= remaining_output_bit,-        _nh2Settings       = NH2.defaultSettings+        _nh2Settings       = NH2.defaultSettings,+        _waiting           = waiting_mvar+         }     return session  --- Tell when we are done with a dession+-- Tell when we are done with a decision sessionIsUndone :: DecoySession -> IO Bool sessionIsUndone session = error "NotImplemented" @@ -73,6 +88,7 @@     let          bs_list = NH2.encodeFrameChunks encode_info frame_payload         input_data_channel = session ^. inputDataChannel+     mapM_ (\ x -> writeChan input_data_channel x ) bs_list  @@ -86,9 +102,13 @@         remaining_output_bit_mvar = decoy_session ^. remainingOutputBit         pull_action = fmap LB.toStrict $ readChan output_data_channel          settings = decoy_session ^. nh2Settings+        waiting_for_read = decoy_session ^. waiting+    my_thread_id <- myThreadId+    putMVar waiting_for_read my_thread_id     remaining_output_bit <- takeMVar remaining_output_bit_mvar     (packet, rest) <- readNextChunkAndContinue http2FrameLength remaining_output_bit pull_action     putMVar remaining_output_bit_mvar rest+    takeMVar waiting_for_read     let          error_or_frame = NH2.decodeFrame settings packet     case error_or_frame of @@ -101,7 +121,13 @@ sendRawDataToSession decoy_session data_to_send = do     let          input_data_channel = decoy_session ^. inputDataChannel+        waiting_for_write = decoy_session ^. waiting++    thread_id <- myThreadId+    putMVar waiting_for_write thread_id      writeChan input_data_channel data_to_send+    takeMVar waiting_for_write+    return ()   -- Read raw data from a session. Normally blocks until data be available.
tests/tests-hs-src/hunit_tests.hs view
@@ -6,6 +6,7 @@ import Test.HUnit  import SecondTransfer.Test.DecoySession+import SecondTransfer  import Tests.HTTP2Session import Tests.Utils@@ -19,7 +20,10 @@     TestLabel "testCRLFLocate" testCRLFLocate,     TestLabel "testHTTP1Parse" testParse,     TestLabel "testGenerate" testGenerate,-    TestLabel "testReplaceHostByAuthority" testReplaceHostByAuthority+    TestLabel "testReplaceHostByAuthority" testReplaceHostByAuthority,+    TestLabel "testFirstFrameIsSettings" testFirstFrameMustBeSettings,+    TestLabel "testFirstFrameIsSettings2" testFirstFrameMustBeSettings2,+    TestLabel "testFirstFrameIsSettings3" testFirstFrameMustBeSettings3     ]