From 44626aace914db058de4273a276a564aeb66b51e Mon Sep 17 00:00:00 2001 From: Lucy Cifferello Date: Wed, 12 Aug 2020 16:19:58 -0600 Subject: [PATCH 1/6] add configurable setting to enable running app for tor --- config/settings.yml | 1 + src/Application.hs | 12 +++++++----- src/Settings.hs | 2 ++ 3 files changed, 10 insertions(+), 5 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index 7cda8fe..e3cd492 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" +enable-tor: "false" database: database: "_env:PG_DATABASE:start9_registry" diff --git a/src/Application.hs b/src/Application.hs index 17c3008..1356645 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, run) import Network.Wai.Handler.WarpTLS import Network.Wai.Middleware.AcceptOverride import Network.Wai.Middleware.Autohead @@ -202,10 +202,12 @@ startWeb foundation = do startWeb' app = do let AppSettings{..} = appSettings foundation putStrLn @Text $ "Launching Web Server on port " <> show appPort - action <- async $ runTLS - (tlsSettings sslCertLocation sslKeyLocation) - (warpSettings foundation) - app + action <- async $ if enableTor + then run (fromIntegral appPort) app + else runTLS + (tlsSettings sslCertLocation sslKeyLocation) + (warpSettings foundation) + app setWebProcessThreadId (asyncThreadId action) foundation void $ waitCatch action diff --git a/src/Settings.hs b/src/Settings.hs index d37148f..17645a5 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -53,6 +53,7 @@ data AppSettings = AppSettings , sslKeyLocation :: FilePath , sslCsrLocation :: FilePath , sslCertLocation :: FilePath + , enableTor :: Bool } instance FromJSON AppSettings where @@ -67,6 +68,7 @@ instance FromJSON AppSettings where resourcesDir <- o .: "resources-path" sslPath <- o .: "ssl-path" registryHostname <- o .: "registry-hostname" + enableTor <- o .: "enable-tor" let sslKeyLocation = sslPath "key.pem" let sslCsrLocation = sslPath "certificate.csr" From 1592ff55ce6d7092d6e77a8a8a07eb1bb57d3e95 Mon Sep 17 00:00:00 2001 From: Lucy Cifferello Date: Wed, 12 Aug 2020 16:21:49 -0600 Subject: [PATCH 2/6] log tor setting --- src/Application.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Application.hs b/src/Application.hs index 1356645..621035b 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -202,6 +202,7 @@ startWeb foundation = do startWeb' app = do let AppSettings{..} = appSettings foundation putStrLn @Text $ "Launching Web Server on port " <> show appPort + putStrLn @Text $ "Tor enabled: " <> show enableTor action <- async $ if enableTor then run (fromIntegral appPort) app else runTLS From b29ed6cade6d8e126a9231f9cbd09f227abab075 Mon Sep 17 00:00:00 2001 From: Lucy Cifferello Date: Fri, 14 Aug 2020 14:48:25 -0600 Subject: [PATCH 3/6] fork process --- src/Application.hs | 23 ++++++++++++----------- src/Foundation.hs | 4 ++-- src/Settings.hs | 2 -- 3 files changed, 14 insertions(+), 15 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index 621035b..310262f 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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 @@ -202,16 +204,14 @@ startWeb foundation = do startWeb' app = do let AppSettings{..} = appSettings foundation putStrLn @Text $ "Launching Web Server on port " <> show appPort - putStrLn @Text $ "Tor enabled: " <> show enableTor - action <- async $ if enableTor - then run (fromIntegral appPort) app - else runTLS - (tlsSettings sslCertLocation sslKeyLocation) - (warpSettings foundation) - app + torAction <- async $ run (fromIntegral appPort) app + action <- async $ runTLS (tlsSettings sslCertLocation sslKeyLocation) + (warpSettings 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 @@ -231,8 +231,9 @@ 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 + _ <- both killThread threadIds + pure () -------------------------------------------------------------- -- Functions for DevelMain.hs (a way to run the RegistryCtx from GHCi) 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 17645a5..d37148f 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -53,7 +53,6 @@ data AppSettings = AppSettings , sslKeyLocation :: FilePath , sslCsrLocation :: FilePath , sslCertLocation :: FilePath - , enableTor :: Bool } instance FromJSON AppSettings where @@ -68,7 +67,6 @@ instance FromJSON AppSettings where resourcesDir <- o .: "resources-path" sslPath <- o .: "ssl-path" registryHostname <- o .: "registry-hostname" - enableTor <- o .: "enable-tor" let sslKeyLocation = sslPath "key.pem" let sslCsrLocation = sslPath "certificate.csr" From 38b65166a920530da8d019986fe368ee7e50a3d8 Mon Sep 17 00:00:00 2001 From: Lucy Cifferello Date: Wed, 19 Aug 2020 11:21:32 -0600 Subject: [PATCH 4/6] fix port --- config/settings.yml | 2 +- src/Application.hs | 25 ++++++++++++------------- src/Settings.hs | 5 ++++- 3 files changed, 17 insertions(+), 15 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index e3cd492..7865304 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -32,7 +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" -enable-tor: "false" +tor-port: "_env:TOR_PORT:447" database: database: "_env:PG_DATABASE:start9_registry" diff --git a/src/Application.hs b/src/Application.hs index 310262f..2a0ec90 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, run) + getPort, setHost, setOnException, setPort, runSettings) import Network.Wai.Handler.WarpTLS import Network.Wai.Middleware.AcceptOverride import Network.Wai.Middleware.Autohead @@ -145,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 @@ -181,7 +181,7 @@ startApp :: RegistryCtx -> IO () startApp foundation = do -- set up ssl certificates putStrLn @Text "Setting up SSL" - _ <- setupSsl $ appSettings foundation + -- _ <- setupSsl $ appSettings foundation putStrLn @Text "SSL Setup Complete" -- certbot renew loop @@ -204,11 +204,11 @@ startWeb foundation = do startWeb' app = do let AppSettings{..} = appSettings foundation putStrLn @Text $ "Launching Web Server on port " <> show appPort - torAction <- async $ run (fromIntegral appPort) app + torAction <- async $ runSettings (warpSettings torPort foundation) app action <- async $ runTLS (tlsSettings sslCertLocation sslKeyLocation) - (warpSettings foundation) + (warpSettings appPort foundation) app - let actions = (,) action torAction + let actions = (action, torAction) setWebProcessThreadId (join (***) asyncThreadId actions) foundation void $ both waitCatch actions @@ -232,17 +232,16 @@ shutdownAll threadIds = do shutdownWeb :: RegistryCtx -> IO () shutdownWeb RegistryCtx{..} = do threadIds <- takeMVar appWebServerThreadId - _ <- both killThread threadIds - pure () + 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/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" From 74564d31708a0b10e1f901d5164a7f4f219bb2f4 Mon Sep 17 00:00:00 2001 From: Lucy Cifferello Date: Wed, 19 Aug 2020 11:52:41 -0600 Subject: [PATCH 5/6] uncomment line --- src/Application.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Application.hs b/src/Application.hs index 2a0ec90..ab50a72 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -181,7 +181,7 @@ startApp :: RegistryCtx -> IO () startApp foundation = do -- set up ssl certificates putStrLn @Text "Setting up SSL" - -- _ <- setupSsl $ appSettings foundation + _ <- setupSsl $ appSettings foundation putStrLn @Text "SSL Setup Complete" -- certbot renew loop From b7724401451ae57e96a1be847dbdb267621b8037 Mon Sep 17 00:00:00 2001 From: Lucy Cifferello Date: Wed, 19 Aug 2020 13:27:40 -0600 Subject: [PATCH 6/6] log starting both web servers --- src/Application.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Application.hs b/src/Application.hs index ab50a72..104a77b 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -203,8 +203,9 @@ startWeb foundation = do where startWeb' app = do let AppSettings{..} = appSettings foundation - putStrLn @Text $ "Launching Web Server on port " <> show appPort + 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 appPort foundation) app