-- |
-- Module      : PostgresWebsockets.Config
-- Description : Manages PostgresWebsockets configuration options.
--
-- This module provides a helper function to read the command line
-- arguments using  the AppConfig type to store
-- them.  It also can be used to define other middleware configuration that
-- may be delegated to some sort of external configuration.
module PostgresWebsockets.Config
  ( prettyVersion,
    loadConfig,
    warpSettings,
    AppConfig (..),
  )
where

import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import Data.String (IsString (..))
import Data.Text (intercalate, pack, replace, strip, stripPrefix)
import Data.Version (versionBranch)
import Env
import Network.Wai.Handler.Warp
import Paths_postgres_websockets (version)
import Protolude hiding (intercalate, optional, replace, toS, (<>))
import Protolude.Conv

-- | Config file settings for the server
data AppConfig = AppConfig
  { AppConfig -> Text
configDatabase :: Text,
    AppConfig -> Maybe Text
configPath :: Maybe Text,
    AppConfig -> Text
configHost :: Text,
    AppConfig -> Int
configPort :: Int,
    AppConfig -> Text
configListenChannel :: Text,
    AppConfig -> Maybe Text
configMetaChannel :: Maybe Text,
    AppConfig -> ByteString
configJwtSecret :: ByteString,
    AppConfig -> Bool
configJwtSecretIsBase64 :: Bool,
    AppConfig -> Int
configPool :: Int,
    AppConfig -> Int
configRetries :: Int,
    AppConfig -> Maybe Int
configReconnectInterval :: Maybe Int,
    AppConfig -> Maybe Text
configCertificateFile :: Maybe Text,
    AppConfig -> Maybe Text
configKeyFile :: Maybe Text
  }
  deriving (Int -> AppConfig -> ShowS
[AppConfig] -> ShowS
AppConfig -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [AppConfig] -> ShowS
$cshowList :: [AppConfig] -> ShowS
show :: AppConfig -> FilePath
$cshow :: AppConfig -> FilePath
showsPrec :: Int -> AppConfig -> ShowS
$cshowsPrec :: Int -> AppConfig -> ShowS
Show)

-- | User friendly version number
prettyVersion :: Text
prettyVersion :: Text
prettyVersion = Text -> [Text] -> Text
intercalate Text
"." forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall a b. (Show a, StringConv FilePath b) => a -> b
show forall a b. (a -> b) -> a -> b
$ Version -> [Int]
versionBranch Version
version

-- | Load all postgres-websockets config from Environment variables. This can be used to use just the middleware or to feed into warpSettings
loadConfig :: IO AppConfig
loadConfig :: IO AppConfig
loadConfig =
  IO AppConfig
readOptions
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AppConfig -> IO AppConfig
verifyTLSConfig
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AppConfig -> IO AppConfig
loadSecretFile
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AppConfig -> IO AppConfig
loadDatabaseURIFile

-- | Given a shutdown handler and an AppConfig builds a Warp Settings to start a stand-alone server
warpSettings :: (IO () -> IO ()) -> AppConfig -> Settings
warpSettings :: (IO () -> IO ()) -> AppConfig -> Settings
warpSettings IO () -> IO ()
waitForShutdown AppConfig {Bool
Int
Maybe Int
Maybe Text
ByteString
Text
configKeyFile :: Maybe Text
configCertificateFile :: Maybe Text
configReconnectInterval :: Maybe Int
configRetries :: Int
configPool :: Int
configJwtSecretIsBase64 :: Bool
configJwtSecret :: ByteString
configMetaChannel :: Maybe Text
configListenChannel :: Text
configPort :: Int
configHost :: Text
configPath :: Maybe Text
configDatabase :: Text
configKeyFile :: AppConfig -> Maybe Text
configCertificateFile :: AppConfig -> Maybe Text
configReconnectInterval :: AppConfig -> Maybe Int
configRetries :: AppConfig -> Int
configPool :: AppConfig -> Int
configJwtSecretIsBase64 :: AppConfig -> Bool
configJwtSecret :: AppConfig -> ByteString
configMetaChannel :: AppConfig -> Maybe Text
configListenChannel :: AppConfig -> Text
configPort :: AppConfig -> Int
configHost :: AppConfig -> Text
configPath :: AppConfig -> Maybe Text
configDatabase :: AppConfig -> Text
..} =
  HostPreference -> Settings -> Settings
setHost (forall a. IsString a => FilePath -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a b. StringConv a b => a -> b
toS Text
configHost)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Settings -> Settings
setPort Int
configPort
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Settings -> Settings
setServerName (forall a b. StringConv a b => a -> b
toS forall a b. (a -> b) -> a -> b
$ Text
"postgres-websockets/" forall a. Semigroup a => a -> a -> a
<> Text
prettyVersion)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Settings -> Settings
setTimeout Int
3600
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IO () -> IO ()) -> Settings -> Settings
setInstallShutdownHandler IO () -> IO ()
waitForShutdown
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> Settings -> Settings
setGracefulShutdownTimeout (forall a. a -> Maybe a
Just Int
5)
    forall a b. (a -> b) -> a -> b
$ Settings
defaultSettings

-- private

-- | Function to read and parse options from the environment
readOptions :: IO AppConfig
readOptions :: IO AppConfig
readOptions =
  forall e a.
AsUnset e =>
(Info Error -> Info e) -> Parser e a -> IO a
Env.parse (forall e. FilePath -> Info e -> Info e
header FilePath
"You need to configure some environment variables to start the service.") forall a b. (a -> b) -> a -> b
$
    Text
-> Maybe Text
-> Text
-> Int
-> Text
-> Maybe Text
-> ByteString
-> Bool
-> Int
-> Int
-> Maybe Int
-> Maybe Text
-> Maybe Text
-> AppConfig
AppConfig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e a.
AsUnset e =>
Reader e a -> FilePath -> Mod Var a -> Parser e a
var (forall s e. IsString s => Reader e s
str forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall e s. (AsEmpty e, IsString s) => Reader e s
nonempty) FilePath
"PGWS_DB_URI" (forall (t :: * -> *) a. HasHelp t => FilePath -> Mod t a
help FilePath
"String to connect to PostgreSQL")
      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 a.
AsUnset e =>
Reader e a -> FilePath -> Mod Var a -> Parser e a
var forall s e. IsString s => Reader e s
str FilePath
"PGWS_ROOT_PATH" (forall (t :: * -> *) a. HasHelp t => FilePath -> Mod t a
help FilePath
"Root path to serve static files, unset to disable."))
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall e a.
AsUnset e =>
Reader e a -> FilePath -> Mod Var a -> Parser e a
var forall s e. IsString s => Reader e s
str FilePath
"PGWS_HOST" (forall a. a -> Mod Var a
def Text
"*4" forall a. Semigroup a => a -> a -> a
<> forall a. (a -> FilePath) -> Mod Var a
helpDef forall a b. (Show a, StringConv FilePath b) => a -> b
show forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a. HasHelp t => FilePath -> Mod t a
help FilePath
"Address the server will listen for websocket connections")
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall e a.
AsUnset e =>
Reader e a -> FilePath -> Mod Var a -> Parser e a
var forall e a. (AsUnread e, Read a) => Reader e a
auto FilePath
"PGWS_PORT" (forall a. a -> Mod Var a
def Int
3000 forall a. Semigroup a => a -> a -> a
<> forall a. (a -> FilePath) -> Mod Var a
helpDef forall a b. (Show a, StringConv FilePath b) => a -> b
show forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a. HasHelp t => FilePath -> Mod t a
help FilePath
"Port the server will listen for websocket connections")
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall e a.
AsUnset e =>
Reader e a -> FilePath -> Mod Var a -> Parser e a
var forall s e. IsString s => Reader e s
str FilePath
"PGWS_LISTEN_CHANNEL" (forall a. a -> Mod Var a
def Text
"postgres-websockets-listener" forall a. Semigroup a => a -> a -> a
<> forall a. (a -> FilePath) -> Mod Var a
helpDef forall a b. (Show a, StringConv FilePath b) => a -> b
show forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a. HasHelp t => FilePath -> Mod t a
help FilePath
"Master channel used in the database to send or read messages in any notification channel")
      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 a.
AsUnset e =>
Reader e a -> FilePath -> Mod Var a -> Parser e a
var forall s e. IsString s => Reader e s
str FilePath
"PGWS_META_CHANNEL" (forall (t :: * -> *) a. HasHelp t => FilePath -> Mod t a
help FilePath
"Websockets channel used to send events about the server state changes."))
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall e a.
AsUnset e =>
Reader e a -> FilePath -> Mod Var a -> Parser e a
var forall s e. IsString s => Reader e s
str FilePath
"PGWS_JWT_SECRET" (forall (t :: * -> *) a. HasHelp t => FilePath -> Mod t a
help FilePath
"Secret used to sign JWT tokens used to open communications channels")
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall e a.
AsUnset e =>
Reader e a -> FilePath -> Mod Var a -> Parser e a
var forall e a. (AsUnread e, Read a) => Reader e a
auto FilePath
"PGWS_JWT_SECRET_BASE64" (forall a. a -> Mod Var a
def Bool
False forall a. Semigroup a => a -> a -> a
<> forall a. (a -> FilePath) -> Mod Var a
helpDef forall a b. (Show a, StringConv FilePath b) => a -> b
show forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a. HasHelp t => FilePath -> Mod t a
help FilePath
"Indicate whether the JWT secret should be decoded from a base64 encoded string")
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall e a.
AsUnset e =>
Reader e a -> FilePath -> Mod Var a -> Parser e a
var forall e a. (AsUnread e, Read a) => Reader e a
auto FilePath
"PGWS_POOL_SIZE" (forall a. a -> Mod Var a
def Int
10 forall a. Semigroup a => a -> a -> a
<> forall a. (a -> FilePath) -> Mod Var a
helpDef forall a b. (Show a, StringConv FilePath b) => a -> b
show forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a. HasHelp t => FilePath -> Mod t a
help FilePath
"How many connection to the database should be used by the connection pool")
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall e a.
AsUnset e =>
Reader e a -> FilePath -> Mod Var a -> Parser e a
var forall e a. (AsUnread e, Read a) => Reader e a
auto FilePath
"PGWS_RETRIES" (forall a. a -> Mod Var a
def Int
5 forall a. Semigroup a => a -> a -> a
<> forall a. (a -> FilePath) -> Mod Var a
helpDef forall a b. (Show a, StringConv FilePath b) => a -> b
show forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a. HasHelp t => FilePath -> Mod t a
help FilePath
"How many times it should try to connect to the database on startup before exiting with an error")
      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 a.
AsUnset e =>
Reader e a -> FilePath -> Mod Var a -> Parser e a
var forall e a. (AsUnread e, Read a) => Reader e a
auto FilePath
"PGWS_CHECK_LISTENER_INTERVAL" (forall a. (a -> FilePath) -> Mod Var a
helpDef forall a b. (Show a, StringConv FilePath b) => a -> b
show forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a. HasHelp t => FilePath -> Mod t a
help FilePath
"Interval for supervisor thread to check if listener connection is alive. 0 to disable it."))
      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 a.
AsUnset e =>
Reader e a -> FilePath -> Mod Var a -> Parser e a
var forall s e. IsString s => Reader e s
str FilePath
"PGWS_CERTIFICATE_FILE" (forall a. (a -> FilePath) -> Mod Var a
helpDef forall a b. (Show a, StringConv FilePath b) => a -> b
show forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a. HasHelp t => FilePath -> Mod t a
help FilePath
"Certificate file to serve secure websockets connection (wss)."))
      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 a.
AsUnset e =>
Reader e a -> FilePath -> Mod Var a -> Parser e a
var forall s e. IsString s => Reader e s
str FilePath
"PGWS_KEY_FILE" (forall a. (a -> FilePath) -> Mod Var a
helpDef forall a b. (Show a, StringConv FilePath b) => a -> b
show forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a. HasHelp t => FilePath -> Mod t a
help FilePath
"Key file to serve secure websockets connection (wss)."))

verifyTLSConfig :: AppConfig -> IO AppConfig
verifyTLSConfig :: AppConfig -> IO AppConfig
verifyTLSConfig conf :: AppConfig
conf@AppConfig {Bool
Int
Maybe Int
Maybe Text
ByteString
Text
configKeyFile :: Maybe Text
configCertificateFile :: Maybe Text
configReconnectInterval :: Maybe Int
configRetries :: Int
configPool :: Int
configJwtSecretIsBase64 :: Bool
configJwtSecret :: ByteString
configMetaChannel :: Maybe Text
configListenChannel :: Text
configPort :: Int
configHost :: Text
configPath :: Maybe Text
configDatabase :: Text
configKeyFile :: AppConfig -> Maybe Text
configCertificateFile :: AppConfig -> Maybe Text
configReconnectInterval :: AppConfig -> Maybe Int
configRetries :: AppConfig -> Int
configPool :: AppConfig -> Int
configJwtSecretIsBase64 :: AppConfig -> Bool
configJwtSecret :: AppConfig -> ByteString
configMetaChannel :: AppConfig -> Maybe Text
configListenChannel :: AppConfig -> Text
configPort :: AppConfig -> Int
configHost :: AppConfig -> Text
configPath :: AppConfig -> Maybe Text
configDatabase :: AppConfig -> Text
..} = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe Text
configCertificateFile forall a. Eq a => a -> a -> Bool
/= forall a. Maybe a -> Bool
isJust Maybe Text
configKeyFile) forall a b. (a -> b) -> a -> b
$
    forall a. HasCallStack => Text -> a
panic Text
"PGWS_TLS_CERTIFICATE and PGWS_TLS_KEY must be set in tandem"
  forall (f :: * -> *) a. Applicative f => a -> f a
pure AppConfig
conf

loadDatabaseURIFile :: AppConfig -> IO AppConfig
loadDatabaseURIFile :: AppConfig -> IO AppConfig
loadDatabaseURIFile conf :: AppConfig
conf@AppConfig {Bool
Int
Maybe Int
Maybe Text
ByteString
Text
configKeyFile :: Maybe Text
configCertificateFile :: Maybe Text
configReconnectInterval :: Maybe Int
configRetries :: Int
configPool :: Int
configJwtSecretIsBase64 :: Bool
configJwtSecret :: ByteString
configMetaChannel :: Maybe Text
configListenChannel :: Text
configPort :: Int
configHost :: Text
configPath :: Maybe Text
configDatabase :: Text
configKeyFile :: AppConfig -> Maybe Text
configCertificateFile :: AppConfig -> Maybe Text
configReconnectInterval :: AppConfig -> Maybe Int
configRetries :: AppConfig -> Int
configPool :: AppConfig -> Int
configJwtSecretIsBase64 :: AppConfig -> Bool
configJwtSecret :: AppConfig -> ByteString
configMetaChannel :: AppConfig -> Maybe Text
configListenChannel :: AppConfig -> Text
configPort :: AppConfig -> Int
configHost :: AppConfig -> Text
configPath :: AppConfig -> Maybe Text
configDatabase :: AppConfig -> Text
..} =
  case Text -> Text -> Maybe Text
stripPrefix Text
"@" Text
configDatabase of
    Maybe Text
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure AppConfig
conf
    Just Text
filename -> Text -> AppConfig
setDatabase forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
strip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Text
readFile (forall a b. StringConv a b => a -> b
toS Text
filename)
  where
    setDatabase :: Text -> AppConfig
setDatabase Text
uri = AppConfig
conf {configDatabase :: Text
configDatabase = Text
uri}

loadSecretFile :: AppConfig -> IO AppConfig
loadSecretFile :: AppConfig -> IO AppConfig
loadSecretFile AppConfig
conf = Text -> IO AppConfig
extractAndTransform Text
secret
  where
    secret :: Text
secret = ByteString -> Text
decodeUtf8 forall a b. (a -> b) -> a -> b
$ AppConfig -> ByteString
configJwtSecret AppConfig
conf
    isB64 :: Bool
isB64 = AppConfig -> Bool
configJwtSecretIsBase64 AppConfig
conf

    extractAndTransform :: Text -> IO AppConfig
    extractAndTransform :: Text -> IO AppConfig
extractAndTransform Text
s =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> AppConfig
setSecret forall a b. (a -> b) -> a -> b
$
        Bool -> ByteString -> IO ByteString
transformString Bool
isB64
          forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< case Text -> Text -> Maybe Text
stripPrefix Text
"@" Text
s of
            Maybe Text
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 forall a b. (a -> b) -> a -> b
$ Text
s
            Just Text
filename -> ByteString -> ByteString
chomp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
BS.readFile (forall a b. StringConv a b => a -> b
toS Text
filename)
      where
        chomp :: ByteString -> ByteString
chomp ByteString
bs = forall a. a -> Maybe a -> a
fromMaybe ByteString
bs (ByteString -> ByteString -> Maybe ByteString
BS.stripSuffix ByteString
"\n" ByteString
bs)

    -- Turns the Base64url encoded JWT into Base64
    transformString :: Bool -> ByteString -> IO ByteString
    transformString :: Bool -> ByteString -> IO ByteString
transformString Bool
False ByteString
t = forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
t
    transformString Bool
True ByteString
t =
      case ByteString -> Either FilePath ByteString
B64.decode forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 forall a b. (a -> b) -> a -> b
$ Text -> Text
strip forall a b. (a -> b) -> a -> b
$ Text -> Text
replaceUrlChars forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 ByteString
t of
        Left FilePath
errMsg -> forall a. HasCallStack => Text -> a
panic forall a b. (a -> b) -> a -> b
$ FilePath -> Text
pack FilePath
errMsg
        Right ByteString
bs -> forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs

    setSecret :: ByteString -> AppConfig
setSecret ByteString
bs = AppConfig
conf {configJwtSecret :: ByteString
configJwtSecret = ByteString
bs}

    -- replace: Replace every occurrence of one substring with another
    replaceUrlChars :: Text -> Text
replaceUrlChars =
      HasCallStack => Text -> Text -> Text -> Text
replace Text
"_" Text
"/" forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
replace Text
"-" Text
"+" forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
replace Text
"." Text
"="