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
""
}
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 :: 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