diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for http-exchange-instantiations + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2023, Andrew Martin + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Andrew Martin nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/app-http-insecure/Main.hs b/app-http-insecure/Main.hs new file mode 100644 --- /dev/null +++ b/app-http-insecure/Main.hs @@ -0,0 +1,35 @@ +{-# language OverloadedStrings #-} + +import Control.Exception (bracket,throwIO) +import Http.Exchange.Network (exchange) +import Http.Types (Request(..),RequestLine(..),Bodied(..),Header(Header)) +import Text.Show.Pretty (pPrint) +import qualified Http.Headers as Headers +import qualified Network.Socket as N + +main :: IO () +main = do + let hints = N.defaultHints { N.addrSocketType = N.Stream } + minfo <- N.getAddrInfo (Just hints) (Just "ifconfig.me") (Just "80") + info <- case minfo of + info : _ -> pure info + [] -> fail "Impossible: getAddrInfo cannot return empty list" + bracket (N.openSocket info) N.close $ \sock -> do + N.connect sock (N.addrAddress info) + result <- exchange sock Bodied + { metadata = Request + { requestLine = RequestLine + { method = "GET" + , path = "/ip" + } + , headers = Headers.fromList + [ Header "Host" "ifconfig.me" + , Header "Accept" "text/plain" + , Header "User-Agent" "curl/0.0.0" + ] + } + , body = mempty + } + case result of + Left e -> throwIO e + Right resp -> pPrint resp diff --git a/app-http-secure/Main.hs b/app-http-secure/Main.hs new file mode 100644 --- /dev/null +++ b/app-http-secure/Main.hs @@ -0,0 +1,59 @@ +{-# language OverloadedStrings #-} + +import Control.Exception (bracket,throwIO) +import Http.Exchange.Tls (SocketThrowingNetworkException(..),exchange) +import Http.Types (Request(..),RequestLine(..),Bodied(..),Header(Header)) +import Text.Show.Pretty (pPrint) +import Data.Default (def) +import qualified Http.Headers as Headers +import qualified Network.Socket as N +import qualified Network.TLS.Extra.Cipher as Tls +import qualified Network.TLS as Tls + +main :: IO () +main = do + let noValidation = Tls.ValidationCache + (\_ _ _ -> return Tls.ValidationCachePass) + (\_ _ _ -> return ()) + let clientParams = (Tls.defaultParamsClient "ifconfig.me" mempty) + { Tls.clientSupported = def + { Tls.supportedVersions = [Tls.TLS13] + , Tls.supportedCiphers = + [ Tls.cipher_TLS13_AES128GCM_SHA256 + , Tls.cipher_TLS13_AES256GCM_SHA384 + , Tls.cipher_TLS13_CHACHA20POLY1305_SHA256 + , Tls.cipher_TLS13_AES128CCM_SHA256 + , Tls.cipher_TLS13_AES128CCM8_SHA256 + ] + } + , Tls.clientShared = def + { Tls.sharedValidationCache = noValidation + } + } + let hints = N.defaultHints { N.addrSocketType = N.Stream } + minfo <- N.getAddrInfo (Just hints) (Just "ifconfig.me") (Just "443") + info <- case minfo of + info : _ -> pure info + [] -> fail "Impossible: getAddrInfo cannot return empty list" + bracket (N.openSocket info) N.close $ \sock -> do + N.connect sock (N.addrAddress info) + ctx <- Tls.contextNew (SocketThrowingNetworkException sock) clientParams + Tls.handshake ctx + result <- exchange ctx Bodied + { metadata = Request + { requestLine = RequestLine + { method = "GET" + , path = "/ip" + } + , headers = Headers.fromList + [ Header "Host" "ifconfig.me" + , Header "Accept" "text/plain" + , Header "User-Agent" "curl/0.0.0" + ] + } + , body = mempty + } + case result of + Left e -> throwIO e + Right resp -> pPrint resp + diff --git a/http-exchange-instantiations.cabal b/http-exchange-instantiations.cabal new file mode 100644 --- /dev/null +++ b/http-exchange-instantiations.cabal @@ -0,0 +1,75 @@ +cabal-version: 3.0 +name: http-exchange-instantiations +version: 0.1.0.0 +synopsis: Instantiations of http-exchange +-- description: +license: BSD-3-Clause +license-file: LICENSE +author: Andrew Martin +maintainer: andrew.thaddeus@gmail.com +copyright: 2023 Andrew Martin +category: Network +build-type: Simple +extra-doc-files: CHANGELOG.md + +library chanimpl + ghc-options: -Wall + exposed-modules: + SocketChannel + TlsChannel + build-depends: + , base >=4.17.1.0 && <5 + , network-unexceptional >=0.1.1 + , network >=3.1.4 + , tls >=1.8 + , error-codes >=0.1.1 + , bytestring >=0.11 + , byteslice >=0.2.11 + hs-source-dirs: src-chanimpl + default-language: GHC2021 + +library + ghc-options: -Wall + exposed-modules: + Http.Exchange.Network + Http.Exchange.Tls + build-depends: + , base >=4.17.1.0 + , network >=3.1.4 + , chanimpl + , http-exchange >=0.1.1 + , http-interchange >=0.3.1 + , tls >=1.7 + hs-source-dirs: src + default-language: GHC2021 + mixins: + http-exchange (Exchange as SocketExchange) + requires (Channel as SocketChannel), + http-exchange (Exchange as TlsExchange) + requires (Channel as TlsChannel) + +executable http-insecure + ghc-options: -Wall + main-is: Main.hs + build-depends: + , base >=4.17.1.0 + , network >=3.1.4 + , http-interchange >=0.3.1 + , http-exchange-instantiations + , pretty-show >=1.10 + hs-source-dirs: app-http-insecure + default-language: GHC2021 + +executable http-secure + ghc-options: -Wall + main-is: Main.hs + build-depends: + , base >=4.17.1.0 + , network >=3.1.4 + , http-interchange >=0.3.1 + , http-exchange-instantiations + , pretty-show >=1.10 + , tls >=1.7 + , data-default >=0.7.1 + hs-source-dirs: app-http-secure + default-language: GHC2021 diff --git a/src-chanimpl/SocketChannel.hs b/src-chanimpl/SocketChannel.hs new file mode 100644 --- /dev/null +++ b/src-chanimpl/SocketChannel.hs @@ -0,0 +1,45 @@ +module SocketChannel + ( M + , SendException + , ReceiveException + , showsPrecSendException + , showsPrecReceiveException + , Resource + , send + , receive + ) where + +import Data.Bytes (Bytes) +import Data.Bytes.Chunks (Chunks) +import Network.Socket (Socket) +import Foreign.C.Error (Errno) + +import qualified Foreign.C.Error.Describe as Describe +import qualified Network.Unexceptional.Bytes as NB +import qualified Network.Unexceptional.Chunks as NC + +type M = IO + +type Resource = Socket +type ReceiveException = Errno +type SendException = Errno + +showsPrecSendException :: Int -> SendException -> String -> String +showsPrecSendException = showsPrecErrno + +showsPrecReceiveException :: Int -> ReceiveException -> String -> String +showsPrecReceiveException = showsPrecErrno + +showsPrecErrno :: Int -> Errno -> String -> String +showsPrecErrno _ e s = Describe.string e ++ (' ' : s) + +send :: + Resource + -> Chunks + -> M (Either Errno ()) +send a b = NC.send a b + +receive :: + Resource + -> M (Either Errno Bytes) +receive a = NB.receive a 12000 diff --git a/src-chanimpl/TlsChannel.hs b/src-chanimpl/TlsChannel.hs new file mode 100644 --- /dev/null +++ b/src-chanimpl/TlsChannel.hs @@ -0,0 +1,133 @@ +{-# language DerivingStrategies #-} +{-# language LambdaCase #-} +{-# language DeriveAnyClass #-} + +module TlsChannel + ( M + , TransportException(..) + , SendException + , ReceiveException + , showsPrecSendException + , showsPrecReceiveException + , Resource + , SocketThrowingNetworkException(..) + , NetworkException(..) + , send + , receive + , tryTls + ) where + +import Data.Bytes (Bytes) +import Data.ByteString (ByteString) +import Data.Bytes.Chunks (Chunks) +import Control.Exception (Exception,IOException,try,throwIO) +import Network.Socket (Socket) +import Foreign.C.Error (Errno) + +import qualified Data.Bytes as Bytes +import qualified Data.List as List +import qualified Data.Bytes.Chunks as Chunks +import qualified Network.Socket as N +import qualified Network.Unexceptional.ByteString as NBS +import qualified Network.TLS as Tls +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString as ByteString +import qualified Foreign.C.Error.Describe as Describe + +type M = IO + +type Resource = Tls.Context +type SendException = TransportException +type ReceiveException = TransportException +data TransportException + = Network !Errno + | System !IOException + | TlsException !Tls.TLSException + +showsPrecErrno :: Int -> Errno -> String -> String +showsPrecErrno _ e s = Describe.string e ++ (' ' : s) + +showsPrecSendException :: Int -> SendException -> String -> String +showsPrecSendException = showsPrec + +showsPrecReceiveException :: Int -> ReceiveException -> String -> String +showsPrecReceiveException = showsPrec + +instance Show TransportException where + showsPrec d (Network e) = showParen (d > 10) + (showString "Network " . showsPrecErrno 11 e) + showsPrec d (System e) = showParen (d > 10) + (showString "System " . showsPrec 11 e) + showsPrec d (TlsException e) = showParen (d > 10) + (showString "TlsException " . showsPrec 11 e) + +data NetworkException = NetworkException !Errno + deriving anyclass (Exception) + +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 +-- try statements to catch all the possible exceptions. +send :: + Tls.Context + -> Chunks + -> IO (Either TransportException ()) +send ctx ch = + tryTls $ Tls.sendData ctx (LBS.fromStrict (Chunks.concatByteString ch)) + +receive :: + Tls.Context + -> M (Either TransportException Bytes) +receive a = tryTls (Tls.recvData a) >>= \case + Left err -> pure (Left err) + Right b -> pure $! Right $! Bytes.fromByteString b + +tryTls :: IO a -> IO (Either TransportException a) +tryTls action = do + e0 <- try $ try $ try $ action + case e0 of + Left (NetworkException err) -> pure (Left (Network err)) + Right e1 -> case e1 of + Left (err :: Tls.TLSException) -> pure (Left (TlsException err)) + Right e2 -> case e2 of + Left (err :: IOException) -> pure (Left (System err)) + Right a -> pure $! Right a diff --git a/src/Http/Exchange/Network.hs b/src/Http/Exchange/Network.hs new file mode 100644 --- /dev/null +++ b/src/Http/Exchange/Network.hs @@ -0,0 +1,106 @@ +-- | Issue insecure HTTP requests using the 'Socket' type from the @network@ +-- library. +module Http.Exchange.Network + ( -- * Issue Requests + exchange + -- * Example Use + -- $example + -- * Exceptions + -- $exceptionnotes + , Exception(..) + , HttpException(..) + ) where + +import Network.Socket (Socket) +import Http.Types (Request,Bodied,Response) + +import SocketExchange (Exception(..),HttpException(..)) +import qualified SocketExchange as X + +-- | 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 +-- than throwing them, so it is not necessary to use @catch@ when calling it. +exchange :: + Socket -- ^ Network socket (TCP or Unix-Domain) + -> Bodied Request -- ^ HTTP Request + -> IO (Either Exception (Bodied Response)) -- ^ HTTP Response or exception +exchange = X.exchange + +{- $example + +Here is an example that illustrates: + +* Resolving a domain name +* Establishing a TCP connection +* Sending and HTTP request and receiving a response + +This example issues a request to @http://ifconfig.me/ip@. +It uses functions like @connect@ and @openSocket@ that can throw +exceptions of type @IOException@. It also uses @throwIO@ to throw +any HTTP-related failures, but it is possible to handle these cases +more gracefully. This example requires the @OverloadedStrings@ extension +to be enabled. It is available in @app-http-insecure/Main.hs@. + +> communicateWithServer :: IO () +> communicateWithServer = do +> let hints = N.defaultHints { N.addrSocketType = N.Stream } +> minfo <- N.getAddrInfo (Just hints) (Just "ifconfig.me") (Just "80") +> info <- case minfo of +> info : _ -> pure info +> [] -> fail "Impossible: getAddrInfo cannot return empty list" +> bracket (N.openSocket info) N.close $ \sock -> do +> N.connect sock (N.addrAddress info) +> result <- exchange sock Bodied +> { metadata = Request +> { requestLine = RequestLine +> { method = "GET" +> , path = "/ip" +> } +> , headers = Headers.fromList +> [ Header "Host" "ifconfig.me" +> , Header "Accept" "text/plain" +> , Header "User-Agent" "curl/0.0.0" +> ] +> } +> , body = mempty +> } +> case result of +> Left e -> throwIO e +> Right resp -> pPrint resp -- Variant of print from pretty-show library + +Running this results in this being printed: + +> Bodied +> { metadata = +> Response +> { statusLine = +> StatusLine +> { statusCode = 200 +> , statusReason = "OK" +> } +> , headers = +> [ Header { name = "access-control-allow-origin" , value = "*" } +> , Header { name = "content-type" , value = "text/plain; charset=utf-8" } +> , Header { name = "content-length" , value = "15" } +> , Header { name = "date" , value = "Tue, 15 Aug 2023 16:42:06 GMT" } +> , Header { name = "x-envoy-upstream-service-time" , value = "1" } +> , Header +> { name = "strict-transport-security" +> , value = "max-age=2592000; includeSubDomains" +> } +> , Header { name = "server" , value = "istio-envoy" } +> , Header { name = "Via" , value = "1.1 google" } +> ] +> } +> , body = ... +> } + +-} + +{- $exceptionnotes + +Note: In the documentation generated by Haddock, the @Send@ and @Receive@ +data constructors in the @Exception@ type show types from an indefinite +module, but in this instantiation, these types are both aliases +for 'Foreign.C.Error.Errno'. +-} diff --git a/src/Http/Exchange/Tls.hs b/src/Http/Exchange/Tls.hs new file mode 100644 --- /dev/null +++ b/src/Http/Exchange/Tls.hs @@ -0,0 +1,136 @@ +-- | Issue HTTPS requests using the 'Context' type from the @tls@ +-- library. +module Http.Exchange.Tls + ( -- * Issue Requests + exchange + -- * Types + , SocketThrowingNetworkException(..) + , NetworkException(..) + , TransportException(..) + -- * Example Use + -- $example + -- * Exceptions + -- $exceptionnotes + , Exception(..) + , HttpException(..) + ) where + +import Network.TLS (Context) +import Http.Types (Request,Bodied,Response) + +import TlsChannel (SocketThrowingNetworkException(..),NetworkException(..)) +import TlsChannel (TransportException(..)) +import TlsExchange (Exception(..),HttpException(..)) +import qualified TlsExchange as X + +-- | 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 +-- than throwing them, so it is not necessary to use @catch@ when calling it. +exchange :: + Context -- ^ TLS Context + -> Bodied Request -- ^ HTTP Request + -> IO (Either Exception (Bodied Response)) -- ^ HTTP Response or exception +exchange = X.exchange + +{- $example + +Here is an example that illustrates: + +* Resolving a domain name +* Establishing a TCP connection +* Sending and HTTP request and receiving a response + +This example issues a request to @https://ifconfig.me/ip@. +It uses functions like @connect@ and @openSocket@ that can throw +exceptions of type @IOException@. It uses @handshake@, which can +throw exceptions of type @TLSException@. It also uses @throwIO@ to throw +any HTTP-related failures, but it is possible to handle these cases +more gracefully. This example requires the @OverloadedStrings@ extension +to be enabled. It is available in @app-http-secure/Main.hs@. + +> communicateWithServer :: IO () +> communicateWithServer = do +> let noValidation = Tls.ValidationCache +> (\_ _ _ -> return Tls.ValidationCachePass) +> (\_ _ _ -> return ()) +> let clientParams = (Tls.defaultParamsClient "ifconfig.me" mempty) +> { Tls.clientSupported = def +> { Tls.supportedVersions = [Tls.TLS13] +> , Tls.supportedCiphers = +> [ Tls.cipher_TLS13_AES128GCM_SHA256 +> , Tls.cipher_TLS13_AES256GCM_SHA384 +> , Tls.cipher_TLS13_CHACHA20POLY1305_SHA256 +> , Tls.cipher_TLS13_AES128CCM_SHA256 +> , Tls.cipher_TLS13_AES128CCM8_SHA256 +> ] +> } +> , Tls.clientShared = def +> { Tls.sharedValidationCache = noValidation +> } +> } +> let hints = N.defaultHints { N.addrSocketType = N.Stream } +> minfo <- N.getAddrInfo (Just hints) (Just "ifconfig.me") (Just "443") +> info <- case minfo of +> info : _ -> pure info +> [] -> fail "Impossible: getAddrInfo cannot return empty list" +> bracket (N.openSocket info) N.close $ \sock -> do +> N.connect sock (N.addrAddress info) +> ctx <- Tls.contextNew (SocketThrowingNetworkException sock) clientParams +> Tls.handshake ctx +> result <- exchange ctx Bodied +> { metadata = Request +> { requestLine = RequestLine +> { method = "GET" +> , path = "/ip" +> } +> , headers = Headers.fromList +> [ Header "Host" "ifconfig.me" +> , Header "Accept" "text/plain" +> , Header "User-Agent" "curl/0.0.0" +> ] +> } +> , body = mempty +> } +> case result of +> Left e -> throwIO e +> Right resp -> pPrint resp + +Running this results in this being printed: + +> Bodied +> { metadata = +> Response +> { statusLine = +> StatusLine { statusCode = 200 , statusReason = "OK" } +> , headers = +> [ Header { name = "access-control-allow-origin" , value = "*" } +> , Header { name = "content-type" , value = "text/plain; charset=utf-8" } +> , Header { name = "content-length" , value = "15" } +> , Header { name = "date" , value = "Tue, 15 Aug 2023 19:57:40 GMT" } +> , Header { name = "x-envoy-upstream-service-time" , value = "2" } +> , Header +> { name = "strict-transport-security" +> , value = "max-age=2592000; includeSubDomains" +> } +> , Header { name = "server" , value = "istio-envoy" } +> , Header { name = "Via" , value = "1.1 google" } +> , Header +> { name = "Alt-Svc" +> , value = "h3=\":443\"; ma=2592000,h3-29=\":443\"; ma=2592000" +> } +> ] +> } +> , body = ... +> } + + +-} + +{- $exceptionnotes + +Note: In the documentation generated by Haddock, the @Send@ and @Receive@ +data constructors in the @Exception@ type show types from an indefinite +module, but in this instantiation, these types are both aliases +for 'Foreign.C.Error.Errno'. +-} +