fix port

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)
 

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"