second-transfer 0.3.0.4 → 0.4.0.0

raw patch · 13 files changed

+156/−151 lines, 13 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• cbits/tlsinc.c +4/−2
• hs-src/SecondTransfer.hs +22/−4
• hs-src/SecondTransfer/Http2.hs +3/−3
• hs-src/SecondTransfer/Http2/Framer.cpphs +14/−4
• hs-src/SecondTransfer/Http2/MakeAttendant.hs +4/−1
• hs-src/SecondTransfer/Http2/Session.cpphs +35/−35
• hs-src/SecondTransfer/MainLoop/CoherentWorker.hs +12/−1
• hs-src/SecondTransfer/MainLoop/Logging.hs +0/−8
• hs-src/SecondTransfer/MainLoop/OpenSSL_TLS.cpphs +8/−4
• hs-src/SecondTransfer/Utils.hs +0/−47
• hs-src/SecondTransfer/Utils/HTTPHeaders.hs +35/−0
• second-transfer.cabal +7/−39
• tests/tests-hs-src/hunit_tests.hs +12/−3

@@ -558,10 +558,12 @@          if ( retval == -1 )         {-            if ( errno == EINTR )+            if ( errno == EINTR )              {                 // printf(".");-                can_go = 0;+                // I get a lot of these signals due to the fact of the +                // Haskell runtime having its own use for signals.+                return TIMEOUT_REACHED;             } else {                 perror("select()");                 return BAD_HAPPENED;

@@ -8,8 +8,18 @@ Portability : POSIX  This library implements enough of the HTTP/2  to build -compliant HTTP/2 servers. The library+compliant HTTP/2 servers.  +Frame encoding and decoding is done with +Kazu Yamamoto's <http://hackage.haskell.org/package/http2 http2> package, our goal+here is to sort the HTTP/2 frames according to the protocol. ++You can find more detailed information about this library at the page +<https://www.httptwo.com/second-transfer/> (but notice that the site uses+the library and doesn't yet talk HTTP/1.1, so use a modern browser).++The library+   * Is concurrent, meaning that you can use amazing Haskell lightweight threads to      process the requests.  @@ -21,11 +31,11 @@     should even be able to do both simultaneously.   Setting up TLS for HTTP/2 correctly is enough of a shore, so I have bundled here the-TLS setup logic. +TLS setup logic. Before you read any further, ATTENTION: enable always the threaded +ghc runtime in your final programs if you want TLS to work. -Frame encoding and decoding is done with -Kazu Yamamoto's <http://hackage.haskell.org/package/http2 http2> package.  + Here is how you create a very basic HTTP/2 webserver:  @@@ -117,6 +127,9 @@     --   its source for the response data. A coherent worker can also present     --   create streams to push to the client.  	  Headers+    , HeaderName+    , HeaderValue+    , Header     , Request     , Footers     , CoherentWorker@@ -132,6 +145,11 @@          -- ** Callback types     ,Attendant+    -- *** Push, Pull and Close actions+    -- +    -- | You don't need to do anything with these types if you are using+    --   `http2Attendant` and `tlsServeWithALPN`. But they are useful if +    --   you want to implement your own layer.     ,PullAction     ,PushAction     ,CloseAction

@@ -4,11 +4,11 @@ 	,makeSessionsContext 	,defaultSessionsConfig 	-- | Configuration information-	,SessionsConfig +	,SessionsConfig(..) 	-- | Context. You need to use `makeSessionsContext` to instance 	--   one of this.  	,SessionsContext-	,SessionsCallbacks+	,SessionsCallbacks(..) 	,ErrorCallback 	,sessionsCallbacks @@ -22,7 +22,7 @@ 	defaultSessionsConfig, 	makeSessionsContext, -	SessionsConfig,+	SessionsConfig(..), 	SessionsContext, 	SessionsCallbacks, 	ErrorCallback,

@@ -144,8 +144,13 @@      let          -- TODO: Dodgy exception handling here...-        close_on_error session_id session_context comp = E.finally (-            E.catch comp (exc_handler session_id session_context)) close_action+        close_on_error session_id session_context comp = +            E.finally (+                E.catch+                    comp+                    (exc_handler session_id session_context)+                    )+                close_action          exc_handler :: Int -> SessionsContext -> FramerException -> IO ()         exc_handler x y e = do@@ -407,8 +412,13 @@      -- And don't forget the thread itself     let -        close_on_error session_id session_context comp = E.finally (-            E.catch comp (exc_handler session_id session_context)) close_action+        close_on_error session_id session_context comp = +            E.finally +                (E.catch +                    comp+                    (exc_handler session_id session_context)+                ) +                close_action          exc_handler :: Int -> SessionsContext -> IOProblem -> IO ()         exc_handler x y e = do

@@ -21,7 +21,10 @@ -- @ --  -- Given a `CoherentWorker`, this function wraps it with flow control, multiplexing,--- and state maintenance needed to run an HTTP/2 session.      +-- and state maintenance needed to run an HTTP/2 session. +--+-- Notice that this function is  using HTTP/2 over TLS. We haven't implemented yet+-- a session handling mechanism for HTTP/1.1 .  http2Attendant :: SessionsContext -> CoherentWorker -> Attendant http2Attendant sessions_context coherent_worker push_action pull_action  close_action = do      let 

@@ -25,8 +25,8 @@     ,SessionsContext(..)     ,SessionCoordinates(..)     ,SessionComponent(..)-    ,SessionsCallbacks-    ,SessionsConfig+    ,SessionsCallbacks(..)+    ,SessionsConfig(..)     ,ErrorCallback      -- Internal stuff@@ -189,6 +189,7 @@ -- | Callbacks that you can provide your sessions to notify you  --   of interesting things happening in the server.  data SessionsCallbacks = SessionsCallbacks {+    -- Callback used to report errors during this session     _reportErrorCallback :: Maybe ErrorCallback } @@ -197,6 +198,7 @@  -- | Configuration information you can provide to the session maker. data SessionsConfig = SessionsConfig {+    -- | Session callbacks     _sessionsCallbacks :: SessionsCallbacks } @@ -254,6 +256,7 @@  -- NH2.Frame != Frame data SessionData = SessionData {+    -- ATTENTION: Ignore the warning coming from here for now     _sessionsContext             :: SessionsContext       ,_sessionInput               :: Chan (Either SessionInputCommand InputFrame)@@ -372,7 +375,8 @@              (SessionOutput session_output) )  -+-- TODO: Some ill clients can break this thread with exceptions. Make these paths a bit+--- more robust. sessionInputThread :: ReaderT SessionData IO () sessionInputThread  = do      INSTRUMENTATION( liftIO $ debugM "HTTP2.Session" "Entering sessionInputThread" )@@ -420,25 +424,27 @@                 let for_worker_thread     = set streamId stream_id for_worker_thread_uns                  headers_bytes             <- getHeaderBytes stream_id                 dyn_table                 <- liftIO $ takeMVar decode_headers_table_mvar-                (new_table, header_list ) <- liftIO $ HP.decodeHeader dyn_table headers_bytes+                (new_table, header_list ) <- liftIO $ {-# SCC "decodeHeader" #-} HP.decodeHeader dyn_table headers_bytes                 -- Good moment to remove the headers from the table.... we don't want a space                 -- leak here -                liftIO $ H.delete stream_request_headers stream_id-                liftIO $ putMVar decode_headers_table_mvar new_table+                liftIO $ do +                    H.delete stream_request_headers stream_id+                    putMVar decode_headers_table_mvar new_table +                -- TODO: Validate headers, abort session if the headers are invalid.+                -- Otherwise other invariants will break!!+                -- THIS IS PROBABLY THE BEST PLACE FOR DOING IT.+                 -- If the headers end the request....                  post_data_source <- if not (frameEndsStream frame)                   then do -                                         mechanism <- createMechanismForStream stream_id                      let source = postDataSourceFromMechanism mechanism                     return $ Just source                   else do                      return Nothing -                 -- I'm clear to start the worker, in its own thread-                -- !!                 liftIO $ do                      thread_id <- forkIO $ runReaderT                          (workerThread (header_list, post_data_source) coherent_worker)@@ -475,12 +481,20 @@         Right frame@(NH2.Frame (NH2.FrameHeader _ _ nh2_stream_id) (NH2.DataFrame somebytes)) -> do              -- So I got data to process             -- TODO: Handle end of stream-            let stream_id = NH2.fromStreamIdentifier nh2_stream_id +            let stream_id = NH2.fromStreamIdentifier nh2_stream_id+            -- TODO: Handle the cases where the stream_id doesn't match an already existent+            -- stream. In such cases it is justified to reset the connection with a  protocol_error.+             streamWorkerSendData stream_id somebytes             -- After that data has been received and forwarded downstream, we can issue a windows update             --             -- TODO: We can use wider frames to avoid congestion...             -- .... and we can also be more compositional with these short bursts of data....+            --+            -- TODO: Consider that the best place to output these frames can be somewhere else...+            --+            -- TODO: Use a special, with-quota queue here to do flow control. Don't send meaningless+            --       WindowUpdateFrame's             sendOutFrame                 (NH2.EncodeInfo                     NH2.defaultFlags@@ -558,10 +572,9 @@     sendOutFrame :: NH2.EncodeInfo -> NH2.FramePayload -> ReaderT SessionData IO ()     sendOutFrame encode_info payload = do          session_output_mvar <- view sessionOutput -        session_output <- liftIO $ takeMVar session_output_mvar +        session_output <- liftIO $ takeMVar session_output_mvar         liftIO $ writeChan session_output $ Right (encode_info, payload)-         liftIO $ putMVar session_output_mvar session_output  @@ -579,6 +592,8 @@   -- TODO: Can be optimized by factoring out the mechanism lookup+-- TODO IMPORTANT: This is a good place to drop the postinputmechanism+-- for a stream, so that unprocessed data can be garbage-collected. closePostDataSource :: GlobalStreamId -> ReaderT SessionData IO () closePostDataSource stream_id = do      stream2postinputmechanism <- view stream2PostInputMechanism@@ -591,8 +606,7 @@             liftIO $ writeChan chan Nothing          Nothing -> -            -- This is an internal error, the mechanism should be -            -- created when the stream ends+            -- TODO: This is a protocol error, handle it properly             error "Internal error/closePostDataSource"  @@ -608,7 +622,8 @@          Nothing ->              -- This is an internal error, the mechanism should be -            -- created when the headers end+            -- created when the headers end (and if the headers +            -- do not finish the stream)             error "Internal error"  @@ -633,14 +648,14 @@     return $ NS.member stream_id cancelled_streams  + workerThread :: Request -> CoherentWorker -> WorkerMonad () workerThread req coherent_worker =   do     headers_output <- view headersOutput     stream_id      <- view streamId-    (headers, _, data_and_conclussion) <- liftIO $ coherent_worker req -    -- liftIO $ putStrLn $ "Num pushed streams: " ++ (show $ length pushed_streams)+    (headers, _, data_and_conclussion) <- liftIO $ coherent_worker req      -- Now I send the headers, if that's possible at all     headers_sent <- liftIO $ newEmptyMVar@@ -661,7 +676,7 @@             (transPipe liftIO data_and_conclussion)              `fuseBothMaybe`              (sendDataOfStream stream_id headers_sent)-        -- BIG TODO: Send the headers ... likely stream conclusion semantics +        -- BIG TODO: Send the footers ... likely stream conclusion semantics          -- will need to be changed.          return ()       else @@ -686,21 +701,6 @@                 consumer data_output  --- sendDataOfStream :: Sink     ----- Allow this very important function to be used in the future to process footers---- difficultFunction :: (Monad m)---                   => ConduitM () a2 m r1 -> ConduitM a2 Void m r2---                   -> m (r2, Maybe r1)--- difficultFunction l r = liftM (fmap getLast) $ runWriterT (l' $$ r')---   where---     l' = transPipe lift l >>= lift . tell . Last . Just---     r' = transPipe lift r--- appendHeaderFragmentBlock :: GlobalStreamId -> B.ByteString -> ReaderT SessionData IO () appendHeaderFragmentBlock global_stream_id bytes = do      ht <- view stream2HeaderBlockFragment @@ -822,8 +822,8 @@                 withLockedSessionOutput                     (\ session_output ->    writeChan session_output $ Right ( NH2.EncodeInfo {                              NH2.encodeFlags     = NH2.setEndStream NH2.defaultFlags-                            ,NH2.encodeStreamId = NH2.toStreamIdentifier stream_id -                            ,NH2.encodePadding  = Nothing }, +                            ,NH2.encodeStreamId  = NH2.toStreamIdentifier stream_id +                            ,NH2.encodePadding   = Nothing },                              NH2.DataFrame ""                             )                         )

@@ -9,6 +9,9 @@ module SecondTransfer.MainLoop.CoherentWorker(     getHeaderFromFlatList +    , HeaderName+    , HeaderValue+    , Header     , Headers     , FinalizationHeaders     , Request@@ -28,14 +31,22 @@ import           Data.Foldable     (find) import           Data.Typeable +-- | The name part of a header+type HeaderName = B.ByteString +-- | The value part of a header+type HeaderValue = B.ByteString++-- | The complete header+type Header = (HeaderName, HeaderValue)+ -- |List of headers. The first part of each tuple is the header name  -- (be sure to conform to the HTTP/2 convention of using lowercase) -- and the second part is the headers contents. This list needs to include -- the special :method, :scheme, :authority and :path pseudo-headers for  -- requests; and :status (with a plain numeric value represented in ascii digits) -- for responses.-type Headers = [(B.ByteString, B.ByteString)]+type Headers = [Header]  -- |This is a Source conduit (see Haskell Data.Conduit library from Michael Snoyman) -- that you can use to retrieve the data sent by the client piece-wise.  

@@ -42,14 +42,6 @@         )     updateGlobalLogger "OpenSSL" (         setHandlers [s] .  -        setLevel INFO  -        )-    updateGlobalLogger "HarWorker" (-        setHandlers [s] .  -        setLevel DEBUG  -        )-    updateGlobalLogger "ResearchWorker" (-        setHandlers [s] .           setLevel DEBUG           )     updateGlobalLogger "HTTP2.Framer" (

@@ -158,7 +158,7 @@             INSTRUMENTATION( errorM "OpenSSL" "Could not create listening socket" )             throwIO $ TLSLayerGenericProblem "Could not create listening end"           else do-            INSTRUMENTATION( infoM "OpenSSL" "Listening soxket created" )+            INSTRUMENTATION( infoM "OpenSSL" "Listening socket created" )             return ()          forever $ do @@ -173,7 +173,7 @@                                         INSTRUMENTATION( infoM "OpenSSL" "A connection was accepted" )                                         return $ Right  p                                     | re == timeoutReached -> tryOnce -                                    | re == badHappened  -> return $ Left "A wait for connection failed"+                                    | re == badHappened  -> return $ Left ("A wait for connection failed" :: String)                         r                  in tryOnce @@ -204,11 +204,13 @@                          -- Ensure that the socket and the struct are only closed once                         closeAction = do+                            -- debugM "OpenSSL" "About to close connection"                             b <- readMVar already_closed_mvar                             if not b                                then do-                                putMVar already_closed_mvar True+                                modifyMVar_ already_closed_mvar (\ _ -> return True)                                 disposeWiredSession wired_ptr+                                -- debugM "OpenSSL" "dispose clalled"                               else                                  return () @@ -313,11 +315,13 @@                                          B.packCStringLen (pcharbuffer, fromIntegral recvd_bytes)                             closeAction = do+                                -- debugM "OpenSSL" "Close action about to be invoked"                                 b <- readMVar already_closed_mvar                                 if not b                                    then do-                                    putMVar already_closed_mvar True+                                    modifyMVar_ already_closed_mvar (\ _ -> return True)                                     disposeWiredSession wired_ptr+                                    -- debugM "OpenSSL" "Close action invoked"                                   else                                      return () 

@@ -6,43 +6,28 @@     ,word24ToInt     ,putWord24be     ,getWord24be-    -- ,getTimeDiff-    -- ,timeAsDouble -    -- ,reportTimedEvent     ,lowercaseText     ,unfoldChannelAndSource     ,stripString-    -- ,neutralizeUrl     ,domainFromUrl-    -- ,hashFromUrl-    -- ,hashSafeFromUrl-    -- ,unSafeUrl -    -- ,SafeUrl     ) where    import           Control.Concurrent.Chan import           Control.Monad.Trans.Class (lift)--- import qualified Crypto.Hash.MD5           as MD5 import           Data.Binary               (Binary, get, put, putWord8) import           Data.Binary.Get           (Get, getWord16be, getWord8) import           Data.Binary.Put           (Put, putWord16be) import           Data.Bits import qualified Data.ByteString           as B--- import qualified Data.ByteString.Base16    as B16 import           Data.ByteString.Char8     (pack, unpack)--- import           Data.Hashable             (Hashable) import           Data.Conduit import qualified Data.Text                 as T import           Data.Text.Encoding import qualified Network.URI               as U--- import qualified System.Clock              as SC--- import           Text.Printf               (printf)--- import qualified Text.Show.ByteString      as S(Show(..))  - strToInt::String -> Int  strToInt = fromIntegral . toInteger . (read::String->Integer) @@ -51,11 +36,6 @@     deriving (Show)  --- Newtype to protect url usage--- newtype SafeUrl = SafeUrl { unSafeUrl :: B.ByteString } deriving (Eq, Show, Hashable)--- word24ToInt :: Word24 -> Int  word24ToInt (Word24 w24) = w24 @@ -117,25 +97,6 @@ stripString  = filter $ \ ch -> (ch /= '\n') && ( ch /= ' ')  --- neutralizeUrl :: B.ByteString -> B.ByteString--- neutralizeUrl url = let ---     Just (U.URI {- scheme -} _ authority u_path u_query u_frag) = U.parseURI $ unpack url---     Just (U.URIAuth _ use_host _) = authority---     complete_url  = U.URI {---         U.uriScheme     = "snu:"---         ,U.uriAuthority = Just $ U.URIAuth {---             U.uriUserInfo = ""---             ,U.uriRegName = use_host ---             ,U.uriPort    = ""---             }---         ,U.uriPath      = u_path---         ,U.uriQuery     = u_query ---         ,U.uriFragment  = u_frag ---       }---   in ---     pack $ show complete_url-- domainFromUrl :: B.ByteString -> B.ByteString domainFromUrl url = let      Just (U.URI {- scheme -} _ authority _ _ _) = U.parseURI $ unpack url@@ -143,11 +104,3 @@   in      pack use_host ---- hashFromUrl :: B.ByteString -> B.ByteString --- hashFromUrl url = ---     B.take 10 . B16.encode . MD5.finalize $ foldl MD5.update MD5.init $  [urlHashSalt, neutralizeUrl url]----- hashSafeFromUrl :: B.ByteString -> SafeUrl --- hashSafeFromUrl = SafeUrl . hashFromUrl

@@ -0,0 +1,35 @@+module SecondTransfer.Utils.HTTPHeaders (+    lowercaseHeaders+    ,headersAreValidHTTP2+    ) where ++import           Data.Char          (isUpper)+import           Data.Text          (toLower)+import qualified Data.Text          as T+import           Data.Text.Encoding (decodeUtf8, encodeUtf8)+++import SecondTransfer.MainLoop.CoherentWorker      (Headers)++-- Why having a headers library? The one at Network.HTTP.Headers works+-- with Strings and is not very friendly to custom headers. +-- This is a very basic, lightweight normalizer.++-- | HTTP headers are case-insensitive, so we can use lowercase versions +-- everywhere+lowercaseHeaders :: Headers -> Headers+lowercaseHeaders = map (\(h,v) -> (low h, v))+  where +    low = encodeUtf8 . toLower . decodeUtf8+++-- | Checks that headers are lowercase+headersAreValidHTTP2 :: Headers -> Bool +headersAreValidHTTP2 headers = +  let +    isOk a_header = not . T.any isUpper . decodeUtf8 . fst $ a_header+  in +    foldl+        (\ prev e -> (flip (&&)) (isOk  e) $! prev)+        True+        headers

@@ -7,13 +7,13 @@ -- PVP       summary:      +-+------- breaking API changes --                         | | +----- non-breaking API additions --                         | | | +--- code changes with no API change-version     :              0.3.0.4+version     :              0.4.0.0  synopsis    :              Second Transfer HTTP/2 web server  description :              Second Transfer HTTP/2 web server -homepage    :              https://github.com/alcidesv/second-transfer+homepage    :              https://www.httptwo.com/second-transfer/  license     :              BSD3 @@ -23,7 +23,8 @@  maintainer  :              alcidesv@zunzun.se -copyright   :              Copyright 2015, Alcides Viamontes Esquivel          +copyright   :              Copyright 2015, Alcides Viamontes Esquivel  + category    :              Network  stability   :              experimental@@ -63,6 +64,7 @@                   , SecondTransfer.MainLoop.Internal                   , SecondTransfer.Exception                   , SecondTransfer.MainLoop.Logging+                  , SecondTransfer.Utils.HTTPHeaders    other-modules:  SecondTransfer.MainLoop.CoherentWorker                 , SecondTransfer.MainLoop.PushPullType@@ -87,56 +89,21 @@      -- Other library packages from which modules are imported.   build-depends: base >=4.7 && < 4.8,-                 -- optparse-applicative-                 -- aeson >= 0.8-                 -- connection >= 0.2 && < 0.3                  exceptions >= 0.8 && < 0.9,                  bytestring == 0.10.4.0,-                 -- base64-bytestring >= 1.0                  base16-bytestring >= 0.1.1,-                 -- data-default == 0.5.3-                 -- tls >= 1.2 && < 1.3-                 -- data-default-class == 0.0.1                  network >= 2.6 && < 2.7,-                 -- x509 == 1.5.0.1-                 -- certificate == 1.3.9-                 -- x509-store ==  1.5.0-                 -- x509-system == 1.5.0                  text >= 1.2 && < 1.3,-                 -- bitset == 1.4.8                  binary == 0.7.1.0,-                 -- pipes == 4.1.4                  containers == 0.5.5.1,-                 -- clock == 0.4.1.3-                 -- network-simple == 0.4.0.2-                 -- pipes-concurrency >= 2.0 && < 2.1-                 -- unix == 2.7.0.1-                 -- filepath == 1.3.0.2-                 -- directory == 1.2.1.0-                 -- asn1-encoding == 0.9.0-                 -- crypto-pubkey >= 0.2.7 && <0.3-                 -- asn1-types == 0.3.0-                 -- crypto-random == 0.0.8-                 -- cryptohash >= 0.11,-                 -- streaming-commons >= 0.1 && < 0.2                  conduit >= 1.2.4 && < 1.3,-                 -- conduit-combinators >= 0.3.0 && < 0.4                  transformers >=0.3 && <= 0.5,-                 -- mmorph == 1.0.4-                 -- QuickCheck ==  2.7.6                  network-uri >= 2.6 && < 2.7,                  hashtables >= 1.2 && < 1.3,-                 -- dequeue == 0.1.5                  lens >= 4.7 && < 4.8,-                 -- base64-bytestring >= 1.0                  http2 >= 0.7,-                 ---- hedis == 0.6.5-                 -- blaze-builder >= 0.3.3 &&  < 0.4-                 -- process >= 1.2 && < 1.3-                 -- void                   hslogger >= 1.2.6,                  hashable >= 1.2-     -- -- asn-data      -- Directories containing source files.   hs-source-dirs: hs-src@@ -155,10 +122,11 @@    -- cc-options: -g3 -O0 -  ghc-options:+  -- ghc-options: -O2    extra-libraries: ssl crypto +  -- NOTICE: Please fill-in with an-up-to date library path here   extra-lib-dirs: /opt/openssl-1.0.2/lib    include-dirs: macros/

@@ -1,16 +1,25 @@++module Main where ++import System.Exit+ import Test.HUnit  import SecondTransfer.Test.DecoySession  import Tests.HTTP2Session+import Tests.Utils   tests = TestList [ 	TestLabel "testPrefaceChecks" testPrefaceChecks,-	TestLabel "testPrefaceChecks2" testPrefaceChecks2+	TestLabel "testPrefaceChecks2" testPrefaceChecks2,+    TestLabel "testLowercaseHeaders" testLowercaseHeaders 	]   main = do -	runTestTT tests -	return ()+    rets <- runTestTT tests +    if (errors rets == 0 && failures rets == 0)+        then exitWith ExitSuccess+        else exitWith $ ExitFailure (-1)