Network/AMQP/Utils/Connection.hs

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