packages feed

http-exchange-instantiations (empty) → 0.1.0.0

raw patch · 9 files changed

+624/−0 lines, 9 filesdep +basedep +byteslicedep +bytestring

Dependencies added: base, byteslice, bytestring, data-default, error-codes, http-exchange, http-exchange-instantiations, http-interchange, network, network-unexceptional, pretty-show, tls

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for http-exchange-instantiations++## 0.1.0.0 -- YYYY-mm-dd++* First version.
+ LICENSE view
@@ -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.
+ app-http-insecure/Main.hs view
@@ -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
+ app-http-secure/Main.hs view
@@ -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+
+ http-exchange-instantiations.cabal view
@@ -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
+ src-chanimpl/SocketChannel.hs view
@@ -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
+ src-chanimpl/TlsChannel.hs view
@@ -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
+ src/Http/Exchange/Network.hs view
@@ -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'.+-}
+ src/Http/Exchange/Tls.hs view
@@ -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'.+-}+