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"