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

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

defaultConnectionInfo :: ConnectionInfo
defaultConnectionInfo :: ConnectionInfo
defaultConnectionInfo = ConnectionInfo :: Bool
-> Maybe String
-> String
-> PortNumber
-> Namespace
-> ConnectionInfo
ConnectionInfo
  { connectionInfoTls :: Bool
connectionInfoTls = Bool
False
  , connectionInfoPassword :: Maybe String
connectionInfoPassword = Maybe String
forall a. Maybe a
Nothing
  , connectionInfoHostName :: String
connectionInfoHostName = String
"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
  String
providerString <- String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"FAKTORY_URL" (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"FAKTORY_PROVIDER"
  String
provider <- Parser String -> String -> String -> IO String
forall a. Parser a -> String -> String -> IO a
parseThrow Parser String
parseProvider String
"FAKTORY_PROVIDER" String
providerString
  String
connectionString <- String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"tcp://localhost:7419" (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
provider
  Parser ConnectionInfo -> String -> String -> IO ConnectionInfo
forall a. Parser a -> String -> String -> IO a
parseThrow Parser ConnectionInfo
parseConnection String
provider String
connectionString

-- | Connect to the given @'Connection'@ as a @'Socket'@
connect :: ConnectionInfo -> IO Connection
connect :: ConnectionInfo -> IO Connection
connect ConnectionInfo {Bool
String
Maybe String
PortNumber
Namespace
connectionInfoNamespace :: Namespace
connectionInfoPort :: PortNumber
connectionInfoHostName :: String
connectionInfoPassword :: Maybe String
connectionInfoTls :: Bool
connectionInfoNamespace :: ConnectionInfo -> Namespace
connectionInfoPort :: ConnectionInfo -> PortNumber
connectionInfoHostName :: ConnectionInfo -> String
connectionInfoPassword :: ConnectionInfo -> Maybe String
connectionInfoTls :: ConnectionInfo -> Bool
..} = IO Connection
-> (Connection -> IO ())
-> (Connection -> IO Connection)
-> IO Connection
forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracketOnError IO Connection
open Connection -> IO ()
connectionClose Connection -> IO Connection
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 :: String
-> PortNumber
-> Maybe TLSSettings
-> Maybe ProxySettings
-> ConnectionParams
ConnectionParams
      { connectionHostname :: String
connectionHostname = String
connectionInfoHostName
      , connectionPort :: PortNumber
connectionPort = PortNumber
connectionInfoPort
      , connectionUseSecure :: Maybe TLSSettings
connectionUseSecure = if Bool
connectionInfoTls
        then TLSSettings -> Maybe TLSSettings
forall a. a -> Maybe a
Just TLSSettingsSimple :: Bool -> Bool -> Bool -> TLSSettings
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 :: Parser a -> String -> String -> IO a
parseThrow Parser a
parser String
name String
value = (ParseErrorBundle String Void -> IO a)
-> (a -> IO a) -> Either (ParseErrorBundle String Void) a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ParseErrorBundle String Void -> IO a
err a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ParseErrorBundle String Void) a -> IO a)
-> Either (ParseErrorBundle String Void) a -> IO a
forall a b. (a -> b) -> a -> b
$ Parser a
-> String -> String -> Either (ParseErrorBundle String Void) a
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parser a
parser String
name String
value
 where
  err :: ParseErrorBundle String Void -> IO a
err ParseErrorBundle String Void
ex = IOError -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (IOError -> IO a) -> (String -> IOError) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IOError
userError (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
    [ String
""
    , String
"\"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
value String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\" is an invalid value for " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":"
    , ParseErrorBundle String Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle String Void
ex
    ]

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

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