{-# language LambdaCase #-}
-- | Issue insecure HTTP requests using the 'Socket' type from the @network@
-- library.
module Http.Exchange.Network
( -- * Issue Requests
exchange
, exchangeInterruptible
, exchangeTimeout
-- * Example Use
-- $example
-- * Exceptions
-- $exceptionnotes
, Exception(..)
, HttpException(..)
) where
import Network.Socket (Socket)
import Http.Types (Request,Bodied,Response)
import SocketExchange (Exception(..),HttpException(..))
import Control.Concurrent.STM (TVar,registerDelay)
import Data.Bifunctor (first)
import qualified SocketInterruptibleChannel as YChan
import qualified SocketInterruptibleExchange as Y
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
-- | Variant of exchange that abandons the attempt if the interrupt
-- variable is set to @True@. If the operation is interrupted in this
-- way, the result is @EAGAIN@ wrapped by either @Send@ or @Receive@.
-- See the implementation of 'exchangeTimeout' for an example of how to
-- use this function to timeout if the HTTP exchange does not complete
-- quickly.
exchangeInterruptible ::
TVar Bool -- ^ Interrupt
-> Socket -- ^ Network socket (TCP or Unix-Domain)
-> Bodied Request -- ^ HTTP Request
-> IO (Either Exception (Bodied Response)) -- ^ HTTP Response or exception
exchangeInterruptible !a b c =
(fmap (first convertException) (Y.exchange (YChan.Resource b a) c))
-- | 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
-> Socket -- ^ Network socket (TCP or Unix-Domain)
-> Bodied Request -- ^ HTTP Request
-> IO (Either Exception (Bodied Response)) -- ^ HTTP Response or exception
exchangeTimeout !t sock req = do
interrupt <- registerDelay t
exchangeInterruptible interrupt sock req
-- It would be better to fix this problem by changing the structure
-- of http-exchange. The exceptions types are nominally different,
-- but they are isomorphic.
convertException :: Y.Exception -> X.Exception
convertException = \case
Y.Http x -> X.Http x
Y.Send x -> X.Send x
Y.Receive x -> X.Receive x
{- $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'.
-}