-- |
-- Module      : PostgresWebsockets.Server
-- Description : Functions to start a full stand-alone PostgresWebsockets server.
module PostgresWebsockets.Server
  ( serve,
  )
where

import Network.HTTP.Types (status200)
import Network.Wai (Application, responseLBS)
import Network.Wai.Application.Static (defaultFileServerSettings, staticApp)
import Network.Wai.Handler.Warp (runSettings)
import Network.Wai.Handler.WarpTLS (runTLS, tlsSettings)
import Network.Wai.Middleware.RequestLogger (logStdout)
import PostgresWebsockets.Config (AppConfig (..), warpSettings)
import PostgresWebsockets.Context (mkContext)
import PostgresWebsockets.Middleware (postgresWsMiddleware)
import Protolude

-- | Start a stand-alone warp server using the parameters from AppConfig and a opening a database connection pool.
serve :: AppConfig -> IO ()
serve :: AppConfig -> IO ()
serve conf :: AppConfig
conf@AppConfig {Bool
Int
Maybe Int
Maybe Text
ByteString
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
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
..} = do
  MVar ()
shutdownSignal <- forall a. IO (MVar a)
newEmptyMVar
  forall a (m :: * -> *). (Print a, MonadIO m) => a -> m ()
putStrLn forall a b. (a -> b) -> a -> b
$ (Text
"Listening on port " :: Text) forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv FilePath b) => a -> b
show Int
configPort

  let shutdown :: IO ()
shutdown = forall a (m :: * -> *). (Print a, MonadIO m) => a -> m ()
putErrLn (Text
"Broadcaster connection is dead" :: Text) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. MVar a -> a -> IO ()
putMVar MVar ()
shutdownSignal ()
  Context
ctx <- AppConfig -> IO () -> IO Context
mkContext AppConfig
conf IO ()
shutdown

  let waitForShutdown :: IO () -> IO ()
waitForShutdown IO ()
cl = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (forall a. MVar a -> IO a
takeMVar MVar ()
shutdownSignal forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
cl)
      appSettings :: Settings
appSettings = (IO () -> IO ()) -> AppConfig -> Settings
warpSettings IO () -> IO ()
waitForShutdown AppConfig
conf
      app :: Application
app = Context -> Middleware
postgresWsMiddleware Context
ctx forall a b. (a -> b) -> a -> b
$ Middleware
logStdout forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Application
dummyApp Text -> Application
staticApp' Maybe Text
configPath

  case (Maybe Text
configCertificateFile, Maybe Text
configKeyFile) of
    (Just Text
certificate, Just Text
key) -> TLSSettings -> Settings -> Application -> IO ()
runTLS (FilePath -> FilePath -> TLSSettings
tlsSettings (forall a b. ConvertText a b => a -> b
toS Text
certificate) (forall a b. ConvertText a b => a -> b
toS Text
key)) Settings
appSettings Application
app
    (Maybe Text, Maybe Text)
_ -> Settings -> Application -> IO ()
runSettings Settings
appSettings Application
app

  forall a. Text -> IO a
die Text
"Shutting down server..."
  where
    staticApp' :: Text -> Application
    staticApp' :: Text -> Application
staticApp' = StaticSettings -> Application
staticApp forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> StaticSettings
defaultFileServerSettings forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertText a b => a -> b
toS
    dummyApp :: Application
    dummyApp :: Application
dummyApp Request
_ Response -> IO ResponseReceived
respond =
      Response -> IO ResponseReceived
respond forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status200 [(HeaderName
"Content-Type", ByteString
"text/plain")] ByteString
"Hello, Web!"