mirror of
https://github.com/Start9Labs/registry.git
synced 2026-03-26 10:21:51 +00:00
341 lines
14 KiB
Haskell
341 lines
14 KiB
Haskell
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
module Application
|
|
( appMain
|
|
, develMain
|
|
, makeFoundation
|
|
, makeLogWare
|
|
, shutdownApp
|
|
, shutdownAll
|
|
, shutdownWeb
|
|
, startApp
|
|
, startWeb
|
|
-- * for DevelMain
|
|
, getApplicationRepl
|
|
, getAppSettings
|
|
-- * for GHCI
|
|
, handler
|
|
) where
|
|
|
|
import Startlude hiding (Handler)
|
|
|
|
import Control.Monad.Logger (liftLoc, runLoggingT)
|
|
import Data.Default
|
|
import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr, pgPoolSize, runSqlPool, runMigration)
|
|
import Language.Haskell.TH.Syntax (qLocation)
|
|
import Network.Wai
|
|
import Network.Wai.Handler.Warp (Settings, defaultSettings, defaultShouldDisplayException,
|
|
getPort, setHost, setOnException, setPort, runSettings, setHTTP2Disabled)
|
|
import Network.Wai.Handler.WarpTLS
|
|
import Network.Wai.Middleware.AcceptOverride
|
|
import Network.Wai.Middleware.Autohead
|
|
import Network.Wai.Middleware.Cors (CorsResourcePolicy (..), cors, simpleCorsResourcePolicy)
|
|
import Network.Wai.Middleware.MethodOverride
|
|
import Network.Wai.Middleware.RequestLogger (Destination (Logger), IPAddrSource (..), OutputFormat (..),
|
|
destination, mkRequestLogger, outputFormat)
|
|
import System.IO (hSetBuffering, BufferMode (..))
|
|
import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, toLogStr)
|
|
import Yesod.Core
|
|
import Yesod.Core.Types hiding (Logger)
|
|
import Yesod.Default.Config2
|
|
|
|
-- Import all relevant handler modules here.
|
|
-- Don't forget to add new modules to your cabal file!
|
|
import Foundation
|
|
import Handler.Apps
|
|
import Handler.Icons
|
|
import Handler.Version
|
|
import Handler.Marketplace
|
|
import Lib.Ssl
|
|
import Settings
|
|
import System.Posix.Process
|
|
import System.Time.Extra
|
|
import Model
|
|
import Control.Lens
|
|
import Control.Arrow ((***))
|
|
import Network.HTTP.Types.Header ( hOrigin )
|
|
import Data.List (lookup)
|
|
import Network.Wai.Middleware.RequestLogger.JSON
|
|
|
|
-- 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
|
|
-- comments there for more details.
|
|
mkYesodDispatch "RegistryCtx" resourcesRegistryCtx
|
|
|
|
-- | This function allocates resources (such as a database connection pool),
|
|
-- performs initialization and returns a foundation datatype value. This is also
|
|
-- the place to put your migrate statements to have automatic database
|
|
-- migrations handled by Yesod.
|
|
makeFoundation :: AppSettings -> IO RegistryCtx
|
|
makeFoundation appSettings = do
|
|
-- Some basic initializations: HTTP connection manager, logger, and static
|
|
-- subsite.
|
|
appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
|
|
|
|
appWebServerThreadId <- newEmptyMVar
|
|
appShouldRestartWeb <- newMVar False
|
|
|
|
-- We need a log function to create a connection pool. We need a connection
|
|
-- pool to create our foundation. And we need our foundation to get a
|
|
-- logging function. To get out of this loop, we initially create a
|
|
-- temporary foundation without a real connection pool, get a log function
|
|
-- from there, and then create the real foundation.
|
|
let mkFoundation appConnPool = RegistryCtx {..}
|
|
-- The RegistryCtx {..} syntax is an example of record wild cards. For more
|
|
-- information, see:
|
|
-- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
|
|
tempFoundation = mkFoundation $ panic "connPool forced in tempFoundation"
|
|
logFunc = messageLoggerSource tempFoundation appLogger
|
|
|
|
-- Create the database connection pool
|
|
pool <- flip runLoggingT logFunc $ createPostgresqlPool
|
|
(pgConnStr $ appDatabaseConf appSettings)
|
|
(pgPoolSize . appDatabaseConf $ appSettings)
|
|
|
|
-- Preform database migration using application logging settings
|
|
runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc
|
|
|
|
-- Return the foundation
|
|
return $ mkFoundation pool
|
|
|
|
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
|
|
-- applying some additional middlewares.
|
|
makeApplication :: RegistryCtx -> IO Application
|
|
makeApplication foundation = do
|
|
logWare <- makeLogWare foundation
|
|
let authWare = makeAuthWare foundation
|
|
-- Create the WAI application and apply middlewares
|
|
appPlain <- toWaiAppPlain foundation
|
|
pure . logWare . cors dynamicCorsResourcePolicy . authWare . acceptOverride . autohead . methodOverride $ appPlain
|
|
|
|
dynamicCorsResourcePolicy :: Request -> Maybe CorsResourcePolicy
|
|
dynamicCorsResourcePolicy req = Just . policy . lookup hOrigin $ requestHeaders req
|
|
where
|
|
policy o = simpleCorsResourcePolicy
|
|
{ corsOrigins = (\o' -> ([o'], True)) <$> o
|
|
, corsMethods = ["GET", "POST", "HEAD", "PUT", "DELETE", "TRACE", "CONNECT", "OPTIONS", "PATCH"]
|
|
, corsRequestHeaders = [ "app-version"
|
|
, "Accept"
|
|
, "Accept-Charset"
|
|
, "Accept-Encoding"
|
|
, "Accept-Language"
|
|
, "Accept-Ranges"
|
|
, "Age"
|
|
, "Allow"
|
|
, "Authorization"
|
|
, "Cache-Control"
|
|
, "Connection"
|
|
, "Content-Encoding"
|
|
, "Content-Language"
|
|
, "Content-Length"
|
|
, "Content-Location"
|
|
, "Content-MD5"
|
|
, "Content-Range"
|
|
, "Content-Type"
|
|
, "Date"
|
|
, "ETag"
|
|
, "Expect"
|
|
, "Expires"
|
|
, "From"
|
|
, "Host"
|
|
, "If-Match"
|
|
, "If-Modified-Since"
|
|
, "If-None-Match"
|
|
, "If-Range"
|
|
, "If-Unmodified-Since"
|
|
, "Last-Modified"
|
|
, "Location"
|
|
, "Max-Forwards"
|
|
, "Pragma"
|
|
, "Proxy-Authenticate"
|
|
, "Proxy-Authorization"
|
|
, "Range"
|
|
, "Referer"
|
|
, "Retry-After"
|
|
, "Server"
|
|
, "TE"
|
|
, "Trailer"
|
|
, "Transfer-Encoding"
|
|
, "Upgrade"
|
|
, "User-Agent"
|
|
, "Vary"
|
|
, "Via"
|
|
, "WWW-Authenticate"
|
|
, "Warning"
|
|
, "Content-Disposition"
|
|
, "MIME-Version"
|
|
, "Cookie"
|
|
, "Set-Cookie"
|
|
, "Origin"
|
|
, "Prefer"
|
|
, "Preference-Applied"
|
|
]
|
|
, corsIgnoreFailures = True
|
|
}
|
|
|
|
makeLogWare :: RegistryCtx -> IO Middleware
|
|
makeLogWare foundation =
|
|
mkRequestLogger def
|
|
{ outputFormat =
|
|
if appDetailedRequestLogging $ appSettings foundation
|
|
then Detailed True
|
|
else CustomOutputFormatWithDetailsAndHeaders formatAsJSONWithHeaders
|
|
, destination = Logger $ loggerSet $ appLogger foundation
|
|
}
|
|
|
|
makeAuthWare :: RegistryCtx -> Middleware
|
|
makeAuthWare _ app req res = next
|
|
where
|
|
next :: IO ResponseReceived
|
|
next = app req res
|
|
|
|
-- | Warp settings for the given foundation value.
|
|
warpSettings :: AppPort -> RegistryCtx -> Settings
|
|
warpSettings port foundation =
|
|
setPort (fromIntegral port)
|
|
$ setHost (appHost $ appSettings foundation)
|
|
$ setOnException (\_req e ->
|
|
when (defaultShouldDisplayException e) $ messageLoggerSource
|
|
foundation
|
|
(appLogger foundation)
|
|
$(qLocation >>= liftLoc)
|
|
"yesod"
|
|
LevelError
|
|
(toLogStr $ "Exception from Warp: " ++ show e))
|
|
(setHTTP2Disabled defaultSettings)
|
|
|
|
getAppSettings :: IO AppSettings
|
|
getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv
|
|
|
|
-- | The @main@ function for an executable running this site.
|
|
appMain :: IO ()
|
|
appMain = do
|
|
hSetBuffering stdout LineBuffering
|
|
-- Get the settings from all relevant sources
|
|
settings <- loadYamlSettingsArgs
|
|
-- fall back to compile-time values, set to [] to require values at runtime
|
|
[configSettingsYmlValue]
|
|
|
|
-- allow environment variables to override
|
|
useEnv
|
|
|
|
-- Generate the foundation from the settings
|
|
makeFoundation settings >>= startApp
|
|
|
|
startApp :: RegistryCtx -> IO ()
|
|
startApp foundation = do
|
|
when (sslAuto . appSettings $ foundation) $ do
|
|
-- set up ssl certificates
|
|
putStrLn @Text "Setting up SSL"
|
|
_ <- setupSsl $ appSettings foundation
|
|
putStrLn @Text "SSL Setup Complete"
|
|
|
|
-- certbot renew loop
|
|
void . forkIO $ forever $ flip runReaderT foundation $ do
|
|
shouldRenew <- doesSslNeedRenew
|
|
putStrLn @Text $ "Checking if SSL Certs should be renewed: " <> show shouldRenew
|
|
when shouldRenew $ do
|
|
putStrLn @Text "Renewing SSL Certs."
|
|
renewSslCerts
|
|
liftIO $ restartWeb foundation
|
|
liftIO $ sleep 86_400
|
|
|
|
startWeb foundation
|
|
|
|
startWeb :: RegistryCtx -> IO ()
|
|
startWeb foundation = do
|
|
app <- makeApplication foundation
|
|
startWeb' app
|
|
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 <- if sslAuto
|
|
then async $ runTLS (tlsSettings sslCertLocation sslKeyLocation)
|
|
(warpSettings appPort foundation) app
|
|
else async $ runSettings (warpSettings appPort foundation) app
|
|
let actions = (action, torAction)
|
|
|
|
setWebProcessThreadId (join (***) asyncThreadId actions) foundation
|
|
(clearRes, torRes) <- both waitCatch actions
|
|
case clearRes of
|
|
Left e -> do
|
|
putStr @Text "Clearnet ServerError: "
|
|
print e
|
|
Right _ -> pure ()
|
|
case torRes of
|
|
Left e -> do
|
|
putStr @Text "Tor ServerError: "
|
|
print e
|
|
Right _ -> pure ()
|
|
shouldRestart <- takeMVar (appShouldRestartWeb foundation)
|
|
when shouldRestart $ do
|
|
putMVar (appShouldRestartWeb foundation) False
|
|
putStrLn @Text "Restarting Web Server"
|
|
startWeb' app
|
|
|
|
restartWeb :: RegistryCtx -> IO ()
|
|
restartWeb foundation = do
|
|
void $ swapMVar (appShouldRestartWeb foundation) True
|
|
shutdownWeb foundation
|
|
|
|
shutdownAll :: [ThreadId] -> IO ()
|
|
shutdownAll threadIds = do
|
|
for_ threadIds killThread
|
|
exitImmediately ExitSuccess
|
|
|
|
-- Careful, you should always spawn this within forkIO so as to avoid accidentally killing the running process
|
|
shutdownWeb :: RegistryCtx -> IO ()
|
|
shutdownWeb RegistryCtx{..} = do
|
|
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
|
|
settings <- getAppSettings
|
|
foundation <- getAppSettings >>= makeFoundation
|
|
wsettings <- getDevSettings $ warpSettings (appPort settings) foundation
|
|
app1 <- makeApplication foundation
|
|
return (getPort wsettings, foundation, app1)
|
|
|
|
shutdownApp :: RegistryCtx -> IO ()
|
|
shutdownApp _ = return ()
|
|
|
|
-- | For yesod devel, return the Warp settings and WAI Application.
|
|
getApplicationDev :: AppPort -> IO (Settings, Application)
|
|
getApplicationDev port = do
|
|
settings <- getAppSettings
|
|
foundation <- makeFoundation settings
|
|
app <- makeApplication foundation
|
|
wsettings <- getDevSettings $ warpSettings port foundation
|
|
return (wsettings, app)
|
|
|
|
-- | main function for use by yesod devel
|
|
develMain :: IO ()
|
|
develMain = do
|
|
settings <- getAppSettings
|
|
develMainHelper $ getApplicationDev $ appPort settings
|
|
|
|
---------------------------------------------
|
|
-- Functions for use in development with GHCi
|
|
---------------------------------------------
|
|
|
|
-- | Run a handler
|
|
handler :: Handler a -> IO a
|
|
handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h
|