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
(Namespace -> Namespace -> Bool)
-> (Namespace -> Namespace -> Bool) -> Eq Namespace
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Namespace -> Namespace -> Bool
== :: Namespace -> Namespace -> Bool
$c/= :: Namespace -> Namespace -> Bool
/= :: Namespace -> Namespace -> Bool
Eq, Int -> Namespace -> ShowS
[Namespace] -> ShowS
Namespace -> [Char]
(Int -> Namespace -> ShowS)
-> (Namespace -> [Char])
-> ([Namespace] -> ShowS)
-> Show Namespace
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Namespace -> ShowS
showsPrec :: Int -> Namespace -> ShowS
$cshow :: Namespace -> [Char]
show :: Namespace -> [Char]
$cshowList :: [Namespace] -> ShowS
showList :: [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
(ConnectionInfo -> ConnectionInfo -> Bool)
-> (ConnectionInfo -> ConnectionInfo -> Bool) -> Eq ConnectionInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConnectionInfo -> ConnectionInfo -> Bool
== :: ConnectionInfo -> ConnectionInfo -> Bool
$c/= :: ConnectionInfo -> ConnectionInfo -> Bool
/= :: ConnectionInfo -> ConnectionInfo -> Bool
Eq, Int -> ConnectionInfo -> ShowS
[ConnectionInfo] -> ShowS
ConnectionInfo -> [Char]
(Int -> ConnectionInfo -> ShowS)
-> (ConnectionInfo -> [Char])
-> ([ConnectionInfo] -> ShowS)
-> Show ConnectionInfo
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConnectionInfo -> ShowS
showsPrec :: Int -> ConnectionInfo -> ShowS
$cshow :: ConnectionInfo -> [Char]
show :: ConnectionInfo -> [Char]
$cshowList :: [ConnectionInfo] -> ShowS
showList :: [ConnectionInfo] -> ShowS
Show)

defaultConnectionInfo :: ConnectionInfo
defaultConnectionInfo :: ConnectionInfo
defaultConnectionInfo =
  ConnectionInfo
    { connectionInfoTls :: Bool
connectionInfoTls = Bool
False
    , connectionInfoPassword :: Maybe [Char]
connectionInfoPassword = Maybe [Char]
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 <- [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
"FAKTORY_URL" (Maybe [Char] -> [Char]) -> IO (Maybe [Char]) -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"FAKTORY_PROVIDER"
  [Char]
provider <- Parser [Char] -> [Char] -> [Char] -> IO [Char]
forall a. Parser a -> [Char] -> [Char] -> IO a
parseThrow Parser [Char]
parseProvider [Char]
"FAKTORY_PROVIDER" [Char]
providerString
  [Char]
connectionString <- [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
"tcp://localhost:7419" (Maybe [Char] -> [Char]) -> IO (Maybe [Char]) -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
provider
  Parser ConnectionInfo -> [Char] -> [Char] -> IO ConnectionInfo
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
connectionInfoTls :: ConnectionInfo -> Bool
connectionInfoPassword :: ConnectionInfo -> Maybe [Char]
connectionInfoHostName :: ConnectionInfo -> [Char]
connectionInfoPort :: ConnectionInfo -> PortNumber
connectionInfoNamespace :: ConnectionInfo -> Namespace
connectionInfoTls :: Bool
connectionInfoPassword :: Maybe [Char]
connectionInfoHostName :: [Char]
connectionInfoPort :: PortNumber
connectionInfoNamespace :: Namespace
..} = IO Connection
-> (Connection -> IO ())
-> (Connection -> IO Connection)
-> IO Connection
forall (m :: * -> *) a b c.
(HasCallStack, MonadMask m) =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracketOnError IO Connection
open Connection -> IO ()
connectionClose Connection -> IO Connection
forall a. a -> IO a
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 (ConnectionParams -> IO Connection)
-> ConnectionParams -> IO Connection
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
                TLSSettings -> Maybe TLSSettings
forall a. a -> Maybe a
Just
                  TLSSettingsSimple
                    { settingDisableCertificateValidation :: Bool
settingDisableCertificateValidation = Bool
False
                    , settingDisableSession :: Bool
settingDisableSession = Bool
False
                    , settingUseServerName :: Bool
settingUseServerName = Bool
False
                    }
              else Maybe TLSSettings
forall a. Maybe a
Nothing
        , connectionUseSocks :: Maybe ProxySettings
connectionUseSocks = Maybe ProxySettings
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 = (ParseErrorBundle [Char] Void -> IO a)
-> (a -> IO a) -> Either (ParseErrorBundle [Char] Void) a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ParseErrorBundle [Char] Void -> IO a
err a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ParseErrorBundle [Char] Void) a -> IO a)
-> Either (ParseErrorBundle [Char] Void) a -> IO a
forall a b. (a -> b) -> a -> b
$ Parser a
-> [Char] -> [Char] -> Either (ParseErrorBundle [Char] Void) a
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 =
    IOError -> IO a
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwIO (IOError -> IO a) -> ([Char] -> IOError) -> [Char] -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IOError
userError ([Char] -> IO a) -> [Char] -> IO a
forall a b. (a -> b) -> a -> b
$
      [[Char]] -> [Char]
unlines
        [ [Char]
""
        , [Char]
"\"" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
value [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"\" is an invalid value for " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
name [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
":"
        , ParseErrorBundle [Char] Void -> [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 =
  ParsecT Void [Char] Identity Char -> Parser [Char]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (ParsecT Void [Char] Identity Char
ParsecT Void [Char] Identity (Token [Char])
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
upperChar ParsecT Void [Char] Identity Char
-> ParsecT Void [Char] Identity Char
-> ParsecT Void [Char] Identity Char
forall a.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity a -> ParsecT Void [Char] Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token [Char] -> ParsecT Void [Char] Identity (Token [Char])
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token [Char]
'_') Parser [Char] -> [Char] -> Parser [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 = Parser ConnectionInfo
forall {s} {f :: * -> *} {e}.
(Token s ~ Char, IsString (Tokens s), MonadParsec e s f) =>
f ConnectionInfo
go Parser ConnectionInfo -> [Char] -> Parser ConnectionInfo
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
      (Bool
 -> Maybe [Char]
 -> [Char]
 -> PortNumber
 -> Namespace
 -> ConnectionInfo)
-> f Bool
-> f (Maybe [Char]
      -> [Char] -> PortNumber -> Namespace -> ConnectionInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool
False Bool -> f (Tokens s) -> f Bool
forall a b. a -> f b -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens s -> f (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"tcp://" f Bool -> f Bool -> f Bool
forall a. f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool
True Bool -> f (Tokens s) -> f Bool
forall a b. a -> f b -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens s -> f (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"tcp+tls://")
      f (Maybe [Char]
   -> [Char] -> PortNumber -> Namespace -> ConnectionInfo)
-> f (Maybe [Char])
-> f ([Char] -> PortNumber -> Namespace -> ConnectionInfo)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f [Char] -> f (Maybe [Char])
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Token s -> f (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
':' f Char -> f [Char] -> f [Char]
forall a b. f a -> f b -> f b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> f Char -> f Char -> f [Char]
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill f Char
f (Token s)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle (Token s -> f (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'@'))
      f ([Char] -> PortNumber -> Namespace -> ConnectionInfo)
-> f [Char] -> f (PortNumber -> Namespace -> ConnectionInfo)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f Char -> f Char -> f [Char]
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill f Char
f (Token s)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle (Token s -> f (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
':')
      f (PortNumber -> Namespace -> ConnectionInfo)
-> f PortNumber -> f (Namespace -> ConnectionInfo)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([Char] -> PortNumber
forall a. Read a => [Char] -> a
read ([Char] -> PortNumber) -> f [Char] -> f PortNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Char -> f [Char]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some f Char
f (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar)
      f (Namespace -> ConnectionInfo) -> f Namespace -> f ConnectionInfo
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Maybe [Char] -> Namespace
toNamespace (Maybe [Char] -> Namespace) -> f (Maybe [Char]) -> f Namespace
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f [Char] -> f (Maybe [Char])
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Token s -> f (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'/' f Char -> f [Char] -> f [Char]
forall a b. f a -> f b -> f b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> f Char -> f [Char]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some f Char
f (Token s)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle))
  toNamespace :: Maybe [Char] -> Namespace
toNamespace = Text -> Namespace
Namespace (Text -> Namespace)
-> (Maybe [Char] -> Text) -> Maybe [Char] -> Namespace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ([Char] -> Text) -> Maybe [Char] -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" [Char] -> Text
pack