diff --git a/cbits/tlsinc.c b/cbits/tlsinc.c --- a/cbits/tlsinc.c +++ b/cbits/tlsinc.c @@ -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 diff --git a/hs-src/SecondTransfer.hs b/hs-src/SecondTransfer.hs --- a/hs-src/SecondTransfer.hs +++ b/hs-src/SecondTransfer.hs @@ -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) 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 @@ -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 diff --git a/hs-src/SecondTransfer/Http2.hs b/hs-src/SecondTransfer/Http2.hs --- a/hs-src/SecondTransfer/Http2.hs +++ b/hs-src/SecondTransfer/Http2.hs @@ -2,7 +2,7 @@ Module: SecondTransfer.Http2 -} module SecondTransfer.Http2( - http2Attendant - ) where + http2Attendant + ) where import SecondTransfer.Http2.MakeAttendant(http2Attendant) diff --git a/hs-src/SecondTransfer/Http2/MakeAttendant.hs b/hs-src/SecondTransfer/Http2/MakeAttendant.hs --- a/hs-src/SecondTransfer/Http2/MakeAttendant.hs +++ b/hs-src/SecondTransfer/Http2/MakeAttendant.hs @@ -8,7 +8,7 @@ import SecondTransfer.Sessions.Internal (SessionsContext) import SecondTransfer.MainLoop.CoherentWorker import SecondTransfer.MainLoop.PushPullType ( - --CloseAction, + --CloseAction, --PullAction, --PushAction, Attendant diff --git a/hs-src/SecondTransfer/MainLoop.hs b/hs-src/SecondTransfer/MainLoop.hs --- a/hs-src/SecondTransfer/MainLoop.hs +++ b/hs-src/SecondTransfer/MainLoop.hs @@ -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 diff --git a/hs-src/SecondTransfer/MainLoop/Framer.hs b/hs-src/SecondTransfer/MainLoop/Framer.hs --- a/hs-src/SecondTransfer/MainLoop/Framer.hs +++ b/hs-src/SecondTransfer/MainLoop/Framer.hs @@ -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 diff --git a/hs-src/SecondTransfer/MainLoop/Internal.hs b/hs-src/SecondTransfer/MainLoop/Internal.hs --- a/hs-src/SecondTransfer/MainLoop/Internal.hs +++ b/hs-src/SecondTransfer/MainLoop/Internal.hs @@ -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) diff --git a/hs-src/SecondTransfer/MainLoop/Logging.hs b/hs-src/SecondTransfer/MainLoop/Logging.hs --- a/hs-src/SecondTransfer/MainLoop/Logging.hs +++ b/hs-src/SecondTransfer/MainLoop/Logging.hs @@ -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) diff --git a/hs-src/SecondTransfer/MainLoop/OpenSSL_TLS.cpphs b/hs-src/SecondTransfer/MainLoop/OpenSSL_TLS.cpphs --- a/hs-src/SecondTransfer/MainLoop/OpenSSL_TLS.cpphs +++ b/hs-src/SecondTransfer/MainLoop/OpenSSL_TLS.cpphs @@ -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. diff --git a/hs-src/SecondTransfer/MainLoop/PushPullType.hs b/hs-src/SecondTransfer/MainLoop/PushPullType.hs --- a/hs-src/SecondTransfer/MainLoop/PushPullType.hs +++ b/hs-src/SecondTransfer/MainLoop/PushPullType.hs @@ -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 diff --git a/hs-src/SecondTransfer/MainLoop/Tokens.hs b/hs-src/SecondTransfer/MainLoop/Tokens.hs --- a/hs-src/SecondTransfer/MainLoop/Tokens.hs +++ b/hs-src/SecondTransfer/MainLoop/Tokens.hs @@ -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 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 @@ -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 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.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 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 @@ -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. diff --git a/tests/tests-hs-src/compiling_ok.hs b/tests/tests-hs-src/compiling_ok.hs --- a/tests/tests-hs-src/compiling_ok.hs +++ b/tests/tests-hs-src/compiling_ok.hs @@ -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 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 @@ -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