diff --git a/config/settings.yml b/config/settings.yml index 7cda8fe..7865304 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -32,6 +32,7 @@ app-compatibility-path: "_env:APP_COMPATIBILITY_CONFIG:/etc/start9/registry/comp resources-path: "_env:RESOURCES_PATH:/var/www/html/resources" ssl-path: "_env:SSL_PATH:/var/ssl" registry-hostname: "_env:REGISTRY_HOSTNAME:registry.start9labs.com" +tor-port: "_env:TOR_PORT:447" database: database: "_env:PG_DATABASE:start9_registry" diff --git a/src/Application.hs b/src/Application.hs index 17c3008..104a77b 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -34,7 +34,7 @@ import Database.Persist.Postgresql (createPostgresqlPool, pg import Language.Haskell.TH.Syntax (qLocation) import Network.Wai import Network.Wai.Handler.Warp (Settings, defaultSettings, defaultShouldDisplayException, - getPort, setHost, setOnException, setPort) + getPort, setHost, setOnException, setPort, runSettings) import Network.Wai.Handler.WarpTLS import Network.Wai.Middleware.AcceptOverride import Network.Wai.Middleware.Autohead @@ -59,6 +59,8 @@ import Settings import System.Posix.Process import System.Time.Extra import Model +import Control.Lens +import Control.Arrow ((***)) -- This line actually creates our YesodDispatch instance. It is the second half -- of the call to mkYesodData which occurs in Foundation.hs. Please see the @@ -143,9 +145,9 @@ makeAuthWare _ app req res = next next = app req res -- | Warp settings for the given foundation value. -warpSettings :: RegistryCtx -> Settings -warpSettings foundation = - setPort (fromIntegral . appPort $ appSettings foundation) +warpSettings :: AppPort -> RegistryCtx -> Settings +warpSettings port foundation = + setPort (fromIntegral port) $ setHost (appHost $ appSettings foundation) $ setOnException (\_req e -> when (defaultShouldDisplayException e) $ messageLoggerSource @@ -201,14 +203,16 @@ startWeb foundation = do where startWeb' app = do let AppSettings{..} = appSettings foundation + putStrLn @Text $ "Launching Tor Web Server on port " <> show torPort + torAction <- async $ runSettings (warpSettings torPort foundation) app putStrLn @Text $ "Launching Web Server on port " <> show appPort - action <- async $ runTLS - (tlsSettings sslCertLocation sslKeyLocation) - (warpSettings foundation) - app + action <- async $ runTLS (tlsSettings sslCertLocation sslKeyLocation) + (warpSettings appPort foundation) + app + let actions = (action, torAction) - setWebProcessThreadId (asyncThreadId action) foundation - void $ waitCatch action + setWebProcessThreadId (join (***) asyncThreadId actions) foundation + void $ both waitCatch actions shouldRestart <- takeMVar (appShouldRestartWeb foundation) when shouldRestart $ do putMVar (appShouldRestartWeb foundation) False @@ -228,17 +232,17 @@ shutdownAll threadIds = do -- Careful, you should always spawn this within forkIO so as to avoid accidentally killing the running process shutdownWeb :: RegistryCtx -> IO () shutdownWeb RegistryCtx{..} = do - threadId <- takeMVar appWebServerThreadId - killThread threadId + threadIds <- takeMVar appWebServerThreadId + void $ both killThread threadIds -------------------------------------------------------------- -- Functions for DevelMain.hs (a way to run the RegistryCtx from GHCi) -------------------------------------------------------------- -getApplicationRepl :: IO (Int, RegistryCtx, Application) -getApplicationRepl = do +getApplicationRepl :: AppPort -> IO (Int, RegistryCtx, Application) +getApplicationRepl port = do foundation <- getAppSettings >>= makeFoundation - wsettings <- getDevSettings $ warpSettings foundation + wsettings <- getDevSettings $ warpSettings port foundation app1 <- makeApplication foundation return (getPort wsettings, foundation, app1) diff --git a/src/Foundation.hs b/src/Foundation.hs index 4aa52e5..5e0e323 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -29,13 +29,13 @@ import Yesod.Persist.Core data RegistryCtx = RegistryCtx { appSettings :: AppSettings , appLogger :: Logger - , appWebServerThreadId :: MVar ThreadId + , appWebServerThreadId :: MVar (ThreadId, ThreadId) , appShouldRestartWeb :: MVar Bool , appCompatibilityMap :: HM.HashMap AppVersion AppVersion , appConnPool :: ConnectionPool } -setWebProcessThreadId :: ThreadId -> RegistryCtx -> IO () +setWebProcessThreadId :: (ThreadId, ThreadId) -> RegistryCtx -> IO () setWebProcessThreadId tid a = putMVar (appWebServerThreadId a) $ tid -- This is where we define all of the routes in our application. For a full diff --git a/src/Settings.hs b/src/Settings.hs index d37148f..c01da97 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -31,11 +31,12 @@ import Data.Yaml.Config -- | Runtime settings to configure this application. These settings can be -- loaded from various sources: defaults, environment variables, config files, -- theoretically even a database. +type AppPort = Word16 data AppSettings = AppSettings { appDatabaseConf :: PostgresConf , appHost :: HostPreference -- ^ Host/interface the server should bind to. - , appPort :: Word16 + , appPort :: AppPort -- ^ Port to listen on , appIpFromHeader :: Bool -- ^ Get the IP address from the header when logging. Useful when sitting @@ -53,6 +54,7 @@ data AppSettings = AppSettings , sslKeyLocation :: FilePath , sslCsrLocation :: FilePath , sslCertLocation :: FilePath + , torPort :: AppPort } instance FromJSON AppSettings where @@ -67,6 +69,7 @@ instance FromJSON AppSettings where resourcesDir <- o .: "resources-path" sslPath <- o .: "ssl-path" registryHostname <- o .: "registry-hostname" + torPort <- o .: "tor-port" let sslKeyLocation = sslPath "key.pem" let sslCsrLocation = sslPath "certificate.csr"