Network/AMQP/Utils/Connection.hs

   1 -- SPDX-FileCopyrightText: 2022 Frank Doepper
   2 --
   3 -- SPDX-License-Identifier: GPL-3.0-only
   4
   5 {-# LANGUAGE OverloadedStrings #-}
   6
   7 module Network.AMQP.Utils.Connection where
   8
   9 import qualified Data.ByteString            as B
  10 import           Data.Default.Class
  11 import qualified Data.Text                  as T
  12 import           Network.AMQP
  13 import           Network.AMQP.Utils.Helpers
  14 import           Network.AMQP.Utils.Options
  15 import qualified Network.Connection         as N
  16 import           Network.TLS
  17 import           Network.TLS.Extra
  18 import           System.Timeout
  19 import           System.X509
  20
  21 -- | opens a connection and a channel
  22 connect :: Args -> IO (Connection, Channel)
  23 connect args = do
  24   printparam "server" $ server args
  25   printparam "port" $ portnumber args
  26   printparam "vhost" $ vHost args
  27   printparam "connection_name" $ connectionName args
  28   printparam "heartbeat" $ liftA2 (\ n m -> show n ++ m) (heartBeat args) (Just " s")
  29   printparam "connect timeout" $ [show (connect_timeout args), "s"]
  30   globalCertificateStore <- getSystemCertificateStore
  31   let myTLS =
  32         N.TLSSettings
  33           (defaultParamsClient "" B.empty)
  34             { clientShared =
  35                 def
  36                   { sharedValidationCache = def
  37                   , sharedCAStore = globalCertificateStore
  38                   }
  39             , clientSupported = def {supportedCiphers = ciphersuite_default}
  40             , clientHooks =
  41                 def {onCertificateRequest = myCert (cert args) (key args)}
  42             }
  43   Just conn <-
  44     timeout to $
  45     openConnection''
  46       defaultConnectionOpts
  47         { coAuth =
  48             [ SASLMechanism "EXTERNAL" B.empty Nothing
  49             , plain (T.pack (user args)) (T.pack (pass args))
  50             ]
  51         , coVHost = T.pack $ vHost args
  52         , coTLSSettings =
  53             if (tls args)
  54               then Just (TLSCustom myTLS)
  55               else Nothing
  56         , coServers = [(server args, portnumber args)]
  57         , coHeartbeatDelay = heartBeat args
  58         , coName = fmap T.pack $ connectionName args
  59         }
  60   getServerProperties conn >>= return . (formatheaders fieldshow) >>=
  61     printparam "server properties"
  62   Just chan <- timeout to $ openChannel conn
  63   return (conn, chan)
  64   where
  65     to = connect_timeout args * 1000000
  66
  67 --  addChannelExceptionHandler chan
  68 --                             (\exception -> closeConnection conn >>
  69 --                                  printparam "exiting" (show exception) >>
  70 --                                  killThread tid)
  71 --
  72 -- -- noop sharedValidationCache, handy when debugging
  73 -- noValidation :: ValidationCache
  74 -- noValidation = ValidationCache
  75 --                  (\_ _ _ -> return ValidationCachePass)
  76 --                  (\_ _ _ -> return ())
  77 --
  78 --
  79 -- | provides the TLS client certificate
  80 myCert :: Maybe FilePath -> Maybe FilePath -> t -> IO (Maybe Credential)
  81 myCert (Just cert') (Just key') _ = do
  82   result <- credentialLoadX509 cert' key'
  83   case result of
  84     Left x  -> printparam "ERROR" x >> return Nothing
  85     Right x -> return $ Just x
  86 myCert _ _ _ = return Nothing