module Faktory.Connection
  ( ConnectionInfo(..)
  , Namespace(..)
  , defaultConnectionInfo
  , envConnectionInfo
  , connect
  ) where

import Faktory.Prelude

import Control.Applicative ((<|>))
import Data.Maybe (fromMaybe)
import Data.Void
import Network.Connection.Compat
import Network.Socket (HostName, PortNumber)
import System.Environment (lookupEnv)
import Text.Megaparsec
  (Parsec, anySingle, errorBundlePretty, manyTill, optional, parse, some, (<?>))
import Text.Megaparsec.Char (char, digitChar, string, upperChar)

newtype Namespace = Namespace Text
  deriving newtype (Namespace -> Namespace -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Namespace -> Namespace -> Bool
$c/= :: Namespace -> Namespace -> Bool
== :: Namespace -> Namespace -> Bool
$c== :: Namespace -> Namespace -> Bool
Eq, Int -> Namespace -> ShowS
[Namespace] -> ShowS
Namespace -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Namespace] -> ShowS
$cshowList :: [Namespace] -> ShowS
show :: Namespace -> [Char]
$cshow :: Namespace -> [Char]
showsPrec :: Int -> Namespace -> ShowS
$cshowsPrec :: Int -> Namespace -> ShowS
Show)

data ConnectionInfo = ConnectionInfo
  { ConnectionInfo -> Bool
connectionInfoTls :: Bool
  , ConnectionInfo -> Maybe [Char]
connectionInfoPassword :: Maybe String
  , ConnectionInfo -> [Char]
connectionInfoHostName :: HostName
  , ConnectionInfo -> PortNumber
connectionInfoPort :: PortNumber
  , ConnectionInfo -> Namespace
connectionInfoNamespace :: Namespace
  }
  deriving stock (ConnectionInfo -> ConnectionInfo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConnectionInfo -> ConnectionInfo -> Bool
$c/= :: ConnectionInfo -> ConnectionInfo -> Bool
== :: ConnectionInfo -> ConnectionInfo -> Bool
$c== :: ConnectionInfo -> ConnectionInfo -> Bool
Eq, Int -> ConnectionInfo -> ShowS
[ConnectionInfo] -> ShowS
ConnectionInfo -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ConnectionInfo] -> ShowS
$cshowList :: [ConnectionInfo] -> ShowS
show :: ConnectionInfo -> [Char]
$cshow :: ConnectionInfo -> [Char]
showsPrec :: Int -> ConnectionInfo -> ShowS
$cshowsPrec :: Int -> ConnectionInfo -> ShowS
Show)

defaultConnectionInfo :: ConnectionInfo
defaultConnectionInfo :: ConnectionInfo
defaultConnectionInfo = ConnectionInfo
  { connectionInfoTls :: Bool
connectionInfoTls = Bool
False
  , connectionInfoPassword :: Maybe [Char]
connectionInfoPassword = forall a. Maybe a
Nothing
  , connectionInfoHostName :: [Char]
connectionInfoHostName = [Char]
"localhost"
  , connectionInfoPort :: PortNumber
connectionInfoPort = PortNumber
7419
  , connectionInfoNamespace :: Namespace
connectionInfoNamespace = Text -> Namespace
Namespace Text
""
  }

-- | Parse a @'Connection'@ from environment variables
--
-- > FAKTORY_PROVIDER=FAKTORY_URL
-- > FAKTORY_URL=tcp://:my-password@localhost:7419
--
-- Supported format is @tcp(+tls):\/\/(:password@)host:port(/namespace)@.
--
-- See <https://github.com/contribsys/faktory/wiki/Worker-Lifecycle#url-configuration>.
--
envConnectionInfo :: IO ConnectionInfo
envConnectionInfo :: IO ConnectionInfo
envConnectionInfo = do
  [Char]
providerString <- forall a. a -> Maybe a -> a
fromMaybe [Char]
"FAKTORY_URL" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"FAKTORY_PROVIDER"
  [Char]
provider <- forall a. Parser a -> [Char] -> [Char] -> IO a
parseThrow Parser [Char]
parseProvider [Char]
"FAKTORY_PROVIDER" [Char]
providerString
  [Char]
connectionString <- forall a. a -> Maybe a -> a
fromMaybe [Char]
"tcp://localhost:7419" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
provider
  forall a. Parser a -> [Char] -> [Char] -> IO a
parseThrow Parser ConnectionInfo
parseConnection [Char]
provider [Char]
connectionString

-- | Connect to the given @'Connection'@ as a @'Socket'@
connect :: ConnectionInfo -> IO Connection
connect :: ConnectionInfo -> IO Connection
connect ConnectionInfo {Bool
[Char]
Maybe [Char]
PortNumber
Namespace
connectionInfoNamespace :: Namespace
connectionInfoPort :: PortNumber
connectionInfoHostName :: [Char]
connectionInfoPassword :: Maybe [Char]
connectionInfoTls :: Bool
connectionInfoNamespace :: ConnectionInfo -> Namespace
connectionInfoPort :: ConnectionInfo -> PortNumber
connectionInfoHostName :: ConnectionInfo -> [Char]
connectionInfoPassword :: ConnectionInfo -> Maybe [Char]
connectionInfoTls :: ConnectionInfo -> Bool
..} = forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracketOnError IO Connection
open Connection -> IO ()
connectionClose forall (f :: * -> *) a. Applicative f => a -> f a
pure
 where
  open :: IO Connection
open = do
    ConnectionContext
ctx <- IO ConnectionContext
initConnectionContext
    ConnectionContext -> ConnectionParams -> IO Connection
connectTo ConnectionContext
ctx forall a b. (a -> b) -> a -> b
$ ConnectionParams
      { connectionHostname :: [Char]
connectionHostname = [Char]
connectionInfoHostName
      , connectionPort :: PortNumber
connectionPort = PortNumber
connectionInfoPort
      , connectionUseSecure :: Maybe TLSSettings
connectionUseSecure = if Bool
connectionInfoTls
        then forall a. a -> Maybe a
Just TLSSettingsSimple
          { settingDisableCertificateValidation :: Bool
settingDisableCertificateValidation = Bool
False
          , settingDisableSession :: Bool
settingDisableSession = Bool
False
          , settingUseServerName :: Bool
settingUseServerName = Bool
False
          }
        else forall a. Maybe a
Nothing
      , connectionUseSocks :: Maybe ProxySettings
connectionUseSocks = forall a. Maybe a
Nothing
      }

type Parser = Parsec Void String

parseThrow :: Parser a -> String -> String -> IO a
parseThrow :: forall a. Parser a -> [Char] -> [Char] -> IO a
parseThrow Parser a
parser [Char]
name [Char]
value = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ParseErrorBundle [Char] Void -> IO a
err forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall e s a.
Parsec e s a -> [Char] -> s -> Either (ParseErrorBundle s e) a
parse Parser a
parser [Char]
name [Char]
value
 where
  err :: ParseErrorBundle [Char] Void -> IO a
err ParseErrorBundle [Char] Void
ex = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IOError
userError forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines
    [ [Char]
""
    , [Char]
"\"" forall a. Semigroup a => a -> a -> a
<> [Char]
value forall a. Semigroup a => a -> a -> a
<> [Char]
"\" is an invalid value for " forall a. Semigroup a => a -> a -> a
<> [Char]
name forall a. Semigroup a => a -> a -> a
<> [Char]
":"
    , forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> [Char]
errorBundlePretty ParseErrorBundle [Char] Void
ex
    ]

parseProvider :: Parser String
parseProvider :: Parser [Char]
parseProvider =
  forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
upperChar forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'_') forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"an environment variable name"

parseConnection :: Parser ConnectionInfo
parseConnection :: Parser ConnectionInfo
parseConnection = forall {s} {f :: * -> *} {e}.
(Token s ~ Char, MonadParsec e s f, IsString (Tokens s)) =>
f ConnectionInfo
go forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"tcp(+tls)://(:<password>@)<host>:<port>(/namespace)"
 where
  go :: f ConnectionInfo
go =
    Bool
-> Maybe [Char]
-> [Char]
-> PortNumber
-> Namespace
-> ConnectionInfo
ConnectionInfo
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool
False forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"tcp://" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"tcp+tls://")
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
':' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'@'))
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
':')
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. Read a => [Char] -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar)
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Maybe [Char] -> Namespace
toNamespace forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'/' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle))
  toNamespace :: Maybe [Char] -> Namespace
toNamespace = Text -> Namespace
Namespace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" [Char] -> Text
pack