second-transfer 0.5.0.0 → 0.5.2.2

raw patch · 17 files changed

+177/−149 lines, 17 filesdep +timedep ~HUnitdep ~basedep ~lens

Dependencies added: time

Dependency ranges changed: HUnit, base, lens

Files

• cbits/tlsinc.c +11/−5
• hs-src/SecondTransfer.hs +5/−2
• hs-src/SecondTransfer/Exception.hs +5/−5
• hs-src/SecondTransfer/Http2.hs +2/−2
• hs-src/SecondTransfer/Http2/MakeAttendant.hs +1/−1
• hs-src/SecondTransfer/MainLoop.hs +6/−6
• hs-src/SecondTransfer/MainLoop/Framer.hs +3/−3
• hs-src/SecondTransfer/MainLoop/Internal.hs +4/−4
• hs-src/SecondTransfer/MainLoop/Logging.hs +3/−3
• hs-src/SecondTransfer/MainLoop/OpenSSL_TLS.cpphs +1/−1
• hs-src/SecondTransfer/MainLoop/PushPullType.hs +4/−4
• hs-src/SecondTransfer/MainLoop/Tokens.hs +7/−7
• hs-src/SecondTransfer/Utils/HTTPHeaders.hs +20/−2
• second-transfer.cabal +11/−10
• tests/tests-hs-src/SecondTransfer/Test/DecoySession.hs +49/−49
• tests/tests-hs-src/compiling_ok.hs +42/−42
• tests/tests-hs-src/hunit_tests.hs +3/−3

@@ -455,10 +455,10 @@          // Now I set a few options....         /*SSL_CTX_set_verify(c->sslContext, NULL );*/-        // const long flags = -        //   SSL_OP_NO_SSLv2 | SSL_OP_NO_SSLv3 | SSL_OP_NO_TLSv1 | SSL_OP_NO_SESSION_RESUMPTION_ON_RENEGOTIATION | SSL_OP_NO_COMPRESSION;         const long flags = -            SSL_OP_NO_SESSION_RESUMPTION_ON_RENEGOTIATION | SSL_OP_NO_COMPRESSION;+          SSL_OP_NO_SSLv2 | SSL_OP_NO_SSLv3 | SSL_OP_NO_TLSv1 | SSL_OP_NO_SESSION_RESUMPTION_ON_RENEGOTIATION | SSL_OP_NO_COMPRESSION;+        // const long flags = +        //     SSL_OP_NO_SESSION_RESUMPTION_ON_RENEGOTIATION | SSL_OP_NO_COMPRESSION;         SSL_CTX_set_options(c->sslContext, flags);         setup_dh_parms( c->sslContext );         SSL_CTX_set_ecdh_auto (c->sslContext, 1);@@ -467,9 +467,15 @@         SSL_CTX_set_tlsext_servername_callback(c->sslContext, ssl_servername_cb);  -         // The only cipher supported by HTTP/2 ... sort of.-        result = SSL_CTX_set_cipher_list(c->sslContext, "ECDHE-RSA-AES128-GCM-SHA256");+        result = SSL_CTX_set_cipher_list(c->sslContext, +            "ECDHE-RSA-AES256-GCM-SHA384"  // <-- Good for Chrome and firefox+            ":ECDHE-RSA-AES128-GCM-SHA256" //  --  ibidem+            // ---- These suites will fail HTTP/2+            ":ECDHE-RSA-AES128-SHA256"     //  -- Not good for HTTP/2+            ":ECDHE-RSA-AES-128-CBC-SHA256"+            ":ECDHE-ECDSA-AES256-SHA384"+            );         /*result = SSL_CTX_set_cipher_list(c->sslContext, "DEFAULT");*/          // Be sure we are able to do ALPN

@@ -90,6 +90,9 @@         "tests\/support\/privkey.pem"      -- Certificate private key         "127.0.0.1"                      -- On which interface to bind         [+            ("no-protocol", http11_attendant), -- The first protocol in the list is used when +                                               -- when no ALPN negotiation happens, and the+                                               -- name is really a filler.             ("h2-14", http2_attendant),    -- Protocols present in the ALPN negotiation             ("h2",    http2_attendant),    -- they may be slightly different, but for this                                             -- test it doesn't matter.@@ -129,7 +132,7 @@     --   the coherent worker can post the response headers and     --   its source for the response data. A coherent worker can also present     --   streams to push to the client. -	  Headers+      Headers     , HeaderName     , HeaderValue     , Header@@ -165,7 +168,7 @@     -- need to configure the loggers. The function `enableConsoleLogging`      -- configures them to output a lot of information to standard output.     ,enableConsoleLogging-	) where +    ) where   import           SecondTransfer.Http1                   (http11Attendant) import           SecondTransfer.Http2.MakeAttendant     (http2Attendant)

@@ -3,10 +3,10 @@ Module      : SecondTransfer.Exception -} module SecondTransfer.Exception (-	-- * Exceptions thrown by the HTTP/2 sessions-	HTTP2SessionException (..)-	,FramerException (..)-	,BadPrefaceException (..)+    -- * Exceptions thrown by the HTTP/2 sessions+    HTTP2SessionException (..)+    ,FramerException (..)+    ,BadPrefaceException (..)     ,HTTP11Exception (..)     ,HTTP11SyntaxException (..)     ,ContentLengthMissingException (..)@@ -15,7 +15,7 @@     ,IOProblem(..)     ,GenericIOProblem(..)     ,StreamCancelledException(..)-	) where +    ) where   import           Control.Exception import           Data.Typeable

@@ -2,7 +2,7 @@ Module: SecondTransfer.Http2 -} module SecondTransfer.Http2(-	http2Attendant-	) where+    http2Attendant+    ) where  import SecondTransfer.Http2.MakeAttendant(http2Attendant)

@@ -8,7 +8,7 @@ import           SecondTransfer.Sessions.Internal       (SessionsContext) import           SecondTransfer.MainLoop.CoherentWorker import           SecondTransfer.MainLoop.PushPullType   (-														 --CloseAction,+                                                         --CloseAction,                                                          --PullAction,                                                           --PushAction,                                                          Attendant

@@ -1,16 +1,16 @@ module SecondTransfer.MainLoop (-	-- * High level OpenSSL functions. -	-- -	-- | Use these functions to create your TLS-compliant -	--   HTTP/2 server in a snap.-	tlsServeWithALPN+    -- * High level OpenSSL functions. +    -- +    -- | Use these functions to create your TLS-compliant +    --   HTTP/2 server in a snap.+    tlsServeWithALPN     ,tlsServeWithALPNAndFinishOnRequest      ,enableConsoleLogging      ,TLSLayerGenericProblem(..)     ,FinishRequest(..)-	) where +    ) where    import           SecondTransfer.MainLoop.OpenSSL_TLS

@@ -4,9 +4,9 @@     ,readNextChunkAndContinue     ,readLength -	,Framer+    ,Framer     ,LengthCallback-	) where+    ) where   import           Control.Monad.Trans.Class (lift)@@ -18,7 +18,7 @@ import qualified Data.ByteString.Lazy      as LB import           Data.Conduit -import           Data.Monoid               (mappend, mempty)+-- import           Data.Monoid               (mappend, mempty)   type Framer m =        LB.ByteString                        -- Input left overs

@@ -1,10 +1,10 @@ {-# OPTIONS_HADDOCK hide #-} module SecondTransfer.MainLoop.Internal(-	readNextChunkAndContinue-	,http2FrameLength-	,OutputFrame+    readNextChunkAndContinue+    ,http2FrameLength+    ,OutputFrame     ,InputFrame-	) where +    ) where    import SecondTransfer.MainLoop.Framer(readNextChunkAndContinue)

@@ -1,8 +1,8 @@ {-# OPTIONS_HADDOCK hide #-} module SecondTransfer.MainLoop.Logging (-	-- | Simple, no fuss enable logging-	enableConsoleLogging-	) where+    -- | Simple, no fuss enable logging+    enableConsoleLogging+    ) where  import           System.IO                 (stderr) 

@@ -125,7 +125,7 @@                       protocol                      ]         ) protocols-+   -- | Simple function to open  tlsServeWithALPN :: FilePath                -- ^ Path to a certificate the server is going to use to identify itself.

@@ -1,11 +1,11 @@ {-# LANGUAGE DeriveDataTypeable, ExistentialQuantification #-} {-# OPTIONS_HADDOCK hide #-} module SecondTransfer.MainLoop.PushPullType (-	PushAction-	,PullAction-	,Attendant+    PushAction+    ,PullAction+    ,Attendant     ,CloseAction-	) where +    ) where    import qualified Data.ByteString              as B

@@ -4,19 +4,19 @@ {-# OPTIONS_HADDOCK hide #-}  module SecondTransfer.MainLoop.Tokens(-	packHeaderTuples-	,unpackHeaderTuples+    packHeaderTuples+    ,unpackHeaderTuples     ,getHeader     ,actionIsForAssociatedStream -	,UnpackedNameValueList (..)-	,StreamInputToken      (..)-	,StreamOutputAction    (..)-	,StreamWorker+    ,UnpackedNameValueList (..)+    ,StreamInputToken      (..)+    ,StreamOutputAction    (..)+    ,StreamWorker     ,StreamWorkerClass     (..)     ,LocalStreamId     ,GlobalStreamId-	) where +    ) where    

@@ -27,12 +27,14 @@     ,replaceHeaderValue     -- ** HTTP utilities     ,replaceHostByAuthority+    ,introduceDateHeader     ) where -+  import qualified Control.Lens                           as L import           Control.Lens                           ( (^.) )  import qualified Data.ByteString                        as B+import           Data.ByteString.Char8                  (pack) import           Data.Char                              (isUpper) import           Data.List                              (find) import           Data.Text                              (toLower)@@ -41,6 +43,9 @@ import qualified Data.Map.Strict                        as Ms import           Data.Word                              (Word8) +import           Data.Time.Format                       (formatTime, defaultTimeLocale)+import           Data.Time.Clock                        (UTCTime,getCurrentTime)+ import           Control.Applicative                    ((<$>))  import           SecondTransfer.MainLoop.CoherentWorker (Headers)@@ -146,6 +151,19 @@     maybe_host_header = headers ^. host_lens     no_hosts = L.set host_lens Nothing headers   in -    case maybe_host_header of +    case maybe_host_header of           Nothing -> headers          Just host -> L.set authority_lens (Just host) no_hosts+++-- | Given a header editor, introduces a "Date" header. This function has +-- a side-effect: to get the current time+introduceDateHeader :: HeaderEditor -> IO HeaderEditor+introduceDateHeader header_editor = do+    current_time <- getCurrentTime+    let +        date_header_lens = headerLens "date"+        formatted_date = Just . pack $+            formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %Z" current_time+        new_editor = L.set date_header_lens formatted_date header_editor +    return new_editor

@@ -7,7 +7,7 @@ -- PVP       summary:      +-+------- breaking API changes --                         | | +----- non-breaking API additions --                         | | | +--- code changes with no API change-version     :              0.5.0.0+version     :              0.5.2.2  synopsis    :              Second Transfer HTTP/2 web server @@ -44,7 +44,7 @@  Flag debug    Description: Enable debug support -  Default:     True+  Default:     False  source-repository head   type:     git@@ -53,7 +53,7 @@ source-repository this   type:     git   location: git@github.com:alcidesv/second-transfer.git-  tag:      0.5.0.0+  tag:      0.5.2.2  library @@ -68,7 +68,6 @@                   -- here for the sake of the test suite. They are hidden                    -- from the documentation.                   , SecondTransfer.MainLoop.Internal-                  , SecondTransfer.MainLoop.OpenSSL_TLS                   , SecondTransfer.Sessions                   , SecondTransfer.Sessions.Config                   , SecondTransfer.Http1.Parse@@ -80,6 +79,7 @@                 , SecondTransfer.MainLoop.Logging                    , SecondTransfer.Sessions.Internal              +                , SecondTransfer.MainLoop.OpenSSL_TLS                 , SecondTransfer.Utils                  , SecondTransfer.Http2.Framer@@ -102,7 +102,7 @@   -- other-extensions:          -- Other library packages from which modules are imported.-  build-depends: base >=4.7 && < 4.8,+  build-depends: base >= 4.7 && <= 4.9,                  exceptions >= 0.8 && < 0.9,                  bytestring >= 0.10.4,                  base16-bytestring >= 0.1.1,@@ -114,11 +114,12 @@                  transformers >=0.3 && <= 0.5,                  network-uri >= 2.6 && < 2.7,                  hashtables >= 1.2 && < 1.3,-                 lens >= 4.7 && < 4.8,+                 lens >= 4.7 ,                  http2 >= 0.7,                  hslogger >= 1.2.6,                  hashable >= 1.2,-                 attoparsec >= 0.12+                 attoparsec >= 0.12,+                 time >= 1.4.0      -- Directories containing source files.   hs-source-dirs: hs-src@@ -155,7 +156,7 @@   main-is         : compiling_ok.hs   hs-source-dirs  : tests/tests-hs-src/   default-language: Haskell2010-  build-depends   : base >=4.7 && < 4.8+  build-depends   : base >=4.7 && <= 4.9                     , second-transfer                     , conduit >= 1.2.4   ghc-options     : -threaded@@ -167,11 +168,11 @@   main-is         : hunit_tests.hs   hs-source-dirs  : tests/tests-hs-src   default-language: Haskell2010-  build-depends   : base >=4.7 && < 4.8+  build-depends   : base >=4.7 && <= 4.9                      ,second-transfer                     ,conduit >= 1.2.4                     ,lens  >= 4.7-                    ,HUnit >= 1.2 && < 1.3+                    ,HUnit >= 1.2 && < 1.5                     ,bytestring >= 0.10.4.0                     ,http2 == 0.9.1   ghc-options     : -threaded

@@ -22,13 +22,13 @@   data DecoySession = DecoySession {-	_inputDataChannel   :: Chan B.ByteString-	,_outputDataChannel :: Chan LB.ByteString-	,_sessionThread     :: ThreadId-	,_remainingOutputBit:: MVar B.ByteString-	,_nh2Settings       :: NH2.Settings-	,_sessionThrowed    :: MVar Bool-	}+    _inputDataChannel   :: Chan B.ByteString+    ,_outputDataChannel :: Chan LB.ByteString+    ,_sessionThread     :: ThreadId+    ,_remainingOutputBit:: MVar B.ByteString+    ,_nh2Settings       :: NH2.Settings+    ,_sessionThrowed    :: MVar Bool+    }   L.makeLenses ''DecoySession@@ -37,29 +37,29 @@ -- Supposed to be an HTTP/2 attendant createDecoySession :: Attendant -> IO DecoySession createDecoySession attendant = do-	input_data_channel  <- newChan -	output_data_channel <- newChan-	let -		push_action :: PushAction-		push_action = writeChan output_data_channel-		pull_action :: PullAction -		pull_action = readChan input_data_channel-		close_action :: CloseAction -		close_action = do-			return ()-		-	thread_id <- forkIO $ do -		attendant push_action pull_action close_action+    input_data_channel  <- newChan +    output_data_channel <- newChan+    let +        push_action :: PushAction+        push_action = writeChan output_data_channel+        pull_action :: PullAction +        pull_action = readChan input_data_channel+        close_action :: CloseAction +        close_action = do+            return ()+        +    thread_id <- forkIO $ do +        attendant push_action pull_action close_action -	remaining_output_bit <- newMVar ""-	let session = DecoySession {-		_inputDataChannel  = input_data_channel,-		_outputDataChannel = output_data_channel,-		_sessionThread     = thread_id,-		_remainingOutputBit= remaining_output_bit,-		_nh2Settings       = NH2.defaultSettings-		}-	return session+    remaining_output_bit <- newMVar ""+    let session = DecoySession {+        _inputDataChannel  = input_data_channel,+        _outputDataChannel = output_data_channel,+        _sessionThread     = thread_id,+        _remainingOutputBit= remaining_output_bit,+        _nh2Settings       = NH2.defaultSettings+        }+    return session   -- Tell when we are done with a dession@@ -70,10 +70,10 @@ -- Send a frame to a session  sendFrameToSession :: DecoySession -> OutputFrame -> IO () sendFrameToSession session (encode_info, frame_payload) = do -	let -		bs_list = NH2.encodeFrameChunks encode_info frame_payload-		input_data_channel = session ^. inputDataChannel-	mapM_ (\ x -> writeChan input_data_channel x ) bs_list+    let +        bs_list = NH2.encodeFrameChunks encode_info frame_payload+        input_data_channel = session ^. inputDataChannel+    mapM_ (\ x -> writeChan input_data_channel x ) bs_list   -- Read a frame from a session... if possible. It will block @@ -81,27 +81,27 @@ -- an exception and/or the session is closed. recvFrameFromSession :: DecoySession ->  IO (Maybe NH2.Frame) recvFrameFromSession decoy_session = do-	let -		output_data_channel = decoy_session ^. outputDataChannel-		remaining_output_bit_mvar = decoy_session ^. remainingOutputBit-		pull_action = fmap LB.toStrict $ readChan output_data_channel -		settings = decoy_session ^. nh2Settings-	remaining_output_bit <- takeMVar remaining_output_bit_mvar-	(packet, rest) <- readNextChunkAndContinue http2FrameLength remaining_output_bit pull_action-	putMVar remaining_output_bit_mvar rest-	let -		error_or_frame = NH2.decodeFrame settings packet-	case error_or_frame of -		Left   _      -> return Nothing -		Right  frame  -> return $ Just frame+    let +        output_data_channel = decoy_session ^. outputDataChannel+        remaining_output_bit_mvar = decoy_session ^. remainingOutputBit+        pull_action = fmap LB.toStrict $ readChan output_data_channel +        settings = decoy_session ^. nh2Settings+    remaining_output_bit <- takeMVar remaining_output_bit_mvar+    (packet, rest) <- readNextChunkAndContinue http2FrameLength remaining_output_bit pull_action+    putMVar remaining_output_bit_mvar rest+    let +        error_or_frame = NH2.decodeFrame settings packet+    case error_or_frame of +        Left   _      -> return Nothing +        Right  frame  -> return $ Just frame   -- Send raw data to a session  sendRawDataToSession :: DecoySession -> B.ByteString -> IO () sendRawDataToSession decoy_session data_to_send = do-	let -		input_data_channel = decoy_session ^. inputDataChannel-	writeChan input_data_channel data_to_send+    let +        input_data_channel = decoy_session ^. inputDataChannel+    writeChan input_data_channel data_to_send   -- Read raw data from a session. Normally blocks until data be available.

@@ -1,17 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} import SecondTransfer(-	CoherentWorker-	, Footers-	, DataAndConclusion-	, tlsServeWithALPNAndFinishOnRequest-	, http2Attendant-	, http11Attendant-	, FinishRequest(..)-	)+    CoherentWorker+    , Footers+    , DataAndConclusion+    , tlsServeWithALPNAndFinishOnRequest+    , http2Attendant+    , http11Attendant+    , FinishRequest(..)+    ) import SecondTransfer.Sessions(-	  makeSessionsContext-	, defaultSessionsConfig-	)+      makeSessionsContext+    , defaultSessionsConfig+    )  import Data.Conduit import Control.Concurrent         (threadDelay, forkIO)@@ -19,43 +19,43 @@  saysHello :: DataAndConclusion saysHello = do -	yield "Hello world!"-	-- No footers-	return []+    yield "Hello world!"+    -- No footers+    return []   helloWorldWorker :: CoherentWorker helloWorldWorker request = return (-	[-		(":status", "200")-	],-	[], -- No pushed streams-	saysHello-	)+    [+        (":status", "200")+    ],+    [], -- No pushed streams+    saysHello+    )   -- For this program to work, it should be run from the top of  -- the developement directory. main = do -	sessions_context <- makeSessionsContext defaultSessionsConfig-	finish <- newEmptyMVar-	-- Make the server work only for small amount of time, so that -	-- continue running other tests-	forkIO $ do -		threadDelay 1000000-		putMVar finish FinishRequest -	let -		http2_attendant = http2Attendant sessions_context helloWorldWorker-		http11_attendant = http11Attendant sessions_context helloWorldWorker-	tlsServeWithALPNAndFinishOnRequest-		"tests/support/servercert.pem"   -- Server certificate-		"tests/support/privkey.pem"      -- Certificate private key-		"127.0.0.1"                      -- On which interface to bind-		[-			("h2-14", http2_attendant),  -- Protocols present in the ALPN negotiation-			("h2",    http2_attendant),   -- they may be slightly different, but for this -			                             -- test it doesn't matter.-			("http/1.1", http11_attendant)-		]-		8000-		finish+    sessions_context <- makeSessionsContext defaultSessionsConfig+    finish <- newEmptyMVar+    -- Make the server work only for small amount of time, so that +    -- continue running other tests+    forkIO $ do +        threadDelay 1000000+        putMVar finish FinishRequest +    let +        http2_attendant = http2Attendant sessions_context helloWorldWorker+        http11_attendant = http11Attendant sessions_context helloWorldWorker+    tlsServeWithALPNAndFinishOnRequest+        "tests/support/servercert.pem"   -- Server certificate+        "tests/support/privkey.pem"      -- Certificate private key+        "127.0.0.1"                      -- On which interface to bind+        [+            ("h2-14", http2_attendant),  -- Protocols present in the ALPN negotiation+            ("h2",    http2_attendant),   -- they may be slightly different, but for this +                                         -- test it doesn't matter.+            ("http/1.1", http11_attendant)+        ]+        8000+        finish

@@ -13,14 +13,14 @@   tests = TestList [-	TestLabel "testPrefaceChecks" testPrefaceChecks,-	TestLabel "testPrefaceChecks2" testPrefaceChecks2,+    TestLabel "testPrefaceChecks" testPrefaceChecks,+    TestLabel "testPrefaceChecks2" testPrefaceChecks2,     TestLabel "testLowercaseHeaders" testLowercaseHeaders,     TestLabel "testCRLFLocate" testCRLFLocate,     TestLabel "testHTTP1Parse" testParse,     TestLabel "testGenerate" testGenerate,     TestLabel "testReplaceHostByAuthority" testReplaceHostByAuthority-	]+    ]   main = do