-- |
-- 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 <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  Text -> IO ()
forall a (m :: * -> *). (Print a, MonadIO m) => a -> m ()
putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ (Text
"Listening on port " :: Text) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show Int
configPort

  let shutdown :: IO ()
shutdown = Text -> IO ()
forall a (m :: * -> *). (Print a, MonadIO m) => a -> m ()
putErrLn (Text
"Broadcaster connection is dead" :: Text) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MVar () -> () -> IO ()
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 = IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
shutdownSignal IO () -> IO () -> IO ()
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 Middleware -> Middleware
forall a b. (a -> b) -> a -> b
$ Middleware
logStdout Middleware -> Middleware
forall a b. (a -> b) -> a -> b
$ Application -> (Text -> Application) -> Maybe Text -> Application
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 (String -> String -> TLSSettings
tlsSettings (Text -> String
forall a b. ConvertText a b => a -> b
toS Text
certificate) (Text -> String
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

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