http-exchange-instantiations 0.1.1.0 → 0.1.2.0
raw patch · 3 files changed
+128/−44 lines, 3 filesdep ~network-unexceptional
Dependency ranges changed: network-unexceptional
Files
- http-exchange-instantiations.cabal +8/−5
- src-chanimpl/TlsChannel.hs +0/−38
- src/Http/Exchange/Tls.hs +120/−1
http-exchange-instantiations.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: http-exchange-instantiations-version: 0.1.1.0+version: 0.1.2.0 synopsis: Instantiations of http-exchange -- description: license: BSD-3-Clause@@ -18,9 +18,10 @@ SocketChannel SocketInterruptibleChannel TlsChannel+ -- TlsInterruptibleChannel build-depends: , base >=4.16.3.0 && <5- , network-unexceptional >=0.1.3+ , network-unexceptional >=0.2 , network >=3.1.4 , tls >=1.8 , error-codes >=0.1.1@@ -36,13 +37,15 @@ Http.Exchange.Network Http.Exchange.Tls build-depends:- , base >=4.17.1.0+ , base >=4.16.3.0 , chanimpl , http-exchange >=0.1.1 , http-interchange >=0.3.1 , network >=3.1.4 , stm >=2.5.1.0 , tls >=1.7+ , network-unexceptional >=0.2+ , bytestring >=0.11 hs-source-dirs: src default-language: GHC2021 mixins:@@ -57,7 +60,7 @@ ghc-options: -Wall main-is: Main.hs build-depends:- , base >=4.17.1.0+ , base >=4.16.3.0 , network >=3.1.4 , http-interchange >=0.3.1 , http-exchange-instantiations@@ -69,7 +72,7 @@ ghc-options: -Wall main-is: Main.hs build-depends:- , base >=4.17.1.0+ , base >=4.16.3.0 , network >=3.1.4 , http-interchange >=0.3.1 , http-exchange-instantiations
src-chanimpl/TlsChannel.hs view
@@ -10,7 +10,6 @@ , showsPrecSendException , showsPrecReceiveException , Resource- , SocketThrowingNetworkException(..) , NetworkException(..) , send , receive@@ -66,43 +65,6 @@ instance Show NetworkException where show (NetworkException e) = Describe.string e---- | Wraps the Socket type. This has different HasBackend instance that--- throws NetworkException instead of IOException.--- Elsewhere, when we call Tls.contextNew to create a TLS context,--- we must use this type instead of Socket.-newtype SocketThrowingNetworkException- = SocketThrowingNetworkException Socket--instance Tls.HasBackend SocketThrowingNetworkException where- initializeBackend _ = pure ()- getBackend (SocketThrowingNetworkException s) =- buildBackendThrowingNetworkException s--buildBackendThrowingNetworkException :: Socket -> Tls.Backend-buildBackendThrowingNetworkException !s = Tls.Backend- { Tls.backendFlush = pure ()- , Tls.backendClose = N.close s- , Tls.backendSend = \b -> NBS.send s b >>= \case- Left e -> throwIO (NetworkException e)- Right () -> pure ()- , Tls.backendRecv = \n -> receiveExactly s n >>= \case- Left e -> throwIO (NetworkException e)- Right bs -> pure bs- }---- Note: this imitates the behavior of the auxiliary function recvAll--- defined in Network.TLS.Backend. If the peer performs an orderly--- shutdown without sending enough bytes, this function returns--- successfully with a number of bytes that is less than expected.-receiveExactly :: Socket -> Int -> IO (Either Errno ByteString)-receiveExactly !s !n0 = go [] n0 where- go !acc 0 = pure (Right (ByteString.concat (List.reverse acc)))- go !acc n = NBS.receive s n >>= \case- Left err -> pure (Left err)- Right b -> case ByteString.length b of- 0 -> pure (Right (ByteString.concat (List.reverse acc)))- m -> go (b : acc) (n - m) -- | There are three types of exceptions that we can get when -- sending/receiving data, so we nest the call to sendData in three
src/Http/Exchange/Tls.hs view
@@ -1,9 +1,16 @@+{-# language LambdaCase #-}+ -- | Issue HTTPS requests using the 'Context' type from the @tls@ -- library. module Http.Exchange.Tls ( -- * Issue Requests exchange+ -- * Issue Interruptible Requests + , exchangeInterruptible+ , exchangeTimeout+ , interruptibleContextNew -- * Types+ , InterruptibleContext , SocketThrowingNetworkException(..) , NetworkException(..) , TransportException(..)@@ -18,10 +25,23 @@ import Network.TLS (Context) import Http.Types (Request,Bodied,Response) -import TlsChannel (SocketThrowingNetworkException(..),NetworkException(..))+import TlsChannel (NetworkException(..)) import TlsChannel (TransportException(..))+import Control.Exception (IOException,try,throwIO) import TlsExchange (Exception(..),HttpException(..))+import Network.Socket (Socket)+import Foreign.C.Error (Errno)+import Foreign.C.Error (Errno)+import Data.IORef (IORef,readIORef,writeIORef,newIORef)+import Control.Concurrent.STM (TVar,registerDelay)+import Data.ByteString (ByteString) import qualified TlsExchange as X+import qualified Data.List as List+import qualified Data.ByteString as ByteString+import qualified Network.Socket as N+import qualified Network.Unexceptional.ByteString as NBS+import qualified Network.TLS as Tls+import qualified Network.Unexceptional.Chunks as NC -- | Issue an HTTP request and await a response. This is does not use TLS -- (i.e. HTTP, not HTTPS). This function returns exceptions in @Left@ rather@@ -32,6 +52,43 @@ -> IO (Either Exception (Bodied Response)) -- ^ HTTP Response or exception exchange = X.exchange +-- | Variant of exchange that abandons the attempt if the interrupt+-- variable is set to @True@. The design of the @tls@ library complicates+-- this function's signature and use. There is an 'InterruptibleContext'+-- type defined in this module that must be used with this function.+-- It is not possible to use the ordinary @Context@ type from @tls@.+-- Example use:+--+-- > clientParams <- ... -- elided for brevity+-- > theAddressInfo <- ... -- elided for brevity+-- > sock <- ... -- elided for brevity+-- > N.connect sock theAddressInfo+-- > ctx <- interruptibleContextNew sock clientParams+-- > Tls.handshake ctx+-- > interrupt <- registerDelay 1_000_000+-- > result <- exchange interrupt ctx Bodied{..} -- request body elided+exchangeInterruptible ::+ TVar Bool -- ^ Interrupt+ -> InterruptibleContext -- ^ TLS Context supporting interruption+ -> Bodied Request -- ^ HTTP Request+ -> IO (Either Exception (Bodied Response)) -- ^ HTTP Response or exception+exchangeInterruptible !intr (InterruptibleContext ctx intrRef) !req = do+ writeIORef intrRef intr+ r <- X.exchange ctx req+ writeIORef intrRef interruptibleContextError+ pure r++-- | Variant of 'exchange' that abandons the exchange if it has not+-- completed in a given number of microseconds.+exchangeTimeout :: + Int -- ^ Microseconds to wait before giving up+ -> InterruptibleContext -- ^ TLS Context supporting interruption+ -> Bodied Request -- ^ HTTP Request+ -> IO (Either Exception (Bodied Response)) -- ^ HTTP Response or exception+exchangeTimeout !t ctx req = do+ interrupt <- registerDelay t+ exchangeInterruptible interrupt ctx req+ {- $example Here is an example that illustrates:@@ -134,3 +191,65 @@ for 'Foreign.C.Error.Errno'. -} +-- | Wraps the Socket type. This has different HasBackend instance that+-- throws NetworkException instead of IOException.+-- Elsewhere, when we call Tls.contextNew to create a TLS context,+-- we must use this type instead of Socket.+newtype SocketThrowingNetworkException+ = SocketThrowingNetworkException Socket++data InterruptibleContext+ = InterruptibleContext !Tls.Context !(IORef (TVar Bool))++interruptibleContextError :: TVar Bool+{-# noinline interruptibleContextError #-}+interruptibleContextError =+ errorWithoutStackTrace "Http.Exchange.Tls: misuse of InterruptibleContext"++-- | Create a new TLS context that supports interrupting exchanges+-- with a 'TVar'.+interruptibleContextNew :: (Tls.TLSParams params)+ => Socket -- ^ Network socket. Must already be connected.+ -> params -- ^ Parameters of the context.+ -> IO InterruptibleContext+interruptibleContextNew socket params = do+ !intrRef <- newIORef interruptibleContextError+ let backend = buildInterruptibleBackend socket intrRef+ context <- Tls.contextNew backend params+ pure (InterruptibleContext context intrRef)++buildInterruptibleBackend :: Socket -> IORef (TVar Bool) -> Tls.Backend+buildInterruptibleBackend s !intrRef = Tls.Backend+ { Tls.backendFlush = pure ()+ , Tls.backendClose = N.close s+ , Tls.backendSend = \b -> do+ !interrupt <- readIORef intrRef+ NBS.sendInterruptible interrupt s b >>= \case+ Left e -> throwIO (NetworkException e)+ Right () -> pure ()+ , Tls.backendRecv = \n -> do+ !interrupt <- readIORef intrRef+ NBS.receiveExactlyInterruptible interrupt s n >>= \case+ Left e -> throwIO (NetworkException e)+ Right bs -> pure bs+ }+instance Tls.HasBackend SocketThrowingNetworkException where+ initializeBackend _ = pure ()+ getBackend (SocketThrowingNetworkException s) =+ buildBackendThrowingNetworkException s++buildBackendThrowingNetworkException :: Socket -> Tls.Backend+buildBackendThrowingNetworkException !s = Tls.Backend+ { Tls.backendFlush = pure ()+ , Tls.backendClose = N.close s+ , Tls.backendSend = \b -> NBS.send s b >>= \case+ Left e -> throwIO (NetworkException e)+ Right () -> pure ()+ -- Note: This receive function does not imitate the behavior of the+ -- auxiliary function recvAll defined in Network.TLS.Backend. If the+ -- peer performs an orderly shutdown without sending enough bytes,+ -- this throws EEOI.+ , Tls.backendRecv = \n -> NBS.receiveExactly s n >>= \case+ Left e -> throwIO (NetworkException e)+ Right bs -> pure bs+ }