mirror of
https://github.com/Start9Labs/start-os.git
synced 2026-03-31 20:43:41 +00:00
0.2.5 initial commit
Makefile incomplete
This commit is contained in:
Aiden McClelland
185
agent/src/Lib/WebServer.hs
Normal file
185
agent/src/Lib/WebServer.hs
Normal file
@@ -0,0 +1,185 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Lib.WebServer where
|
||||
|
||||
import Startlude hiding ( exp )
|
||||
|
||||
import Control.Monad.Logger
|
||||
import Data.Default
|
||||
import Data.IORef
|
||||
import Language.Haskell.TH.Syntax ( qLocation )
|
||||
import Network.Wai
|
||||
import Network.Wai.Handler.Warp ( Settings
|
||||
, defaultSettings
|
||||
, defaultShouldDisplayException
|
||||
, runSettings
|
||||
, setHost
|
||||
, setOnException
|
||||
, setPort
|
||||
)
|
||||
import Network.Wai.Middleware.Cors ( CorsResourcePolicy(..)
|
||||
, cors
|
||||
, simpleCorsResourcePolicy
|
||||
)
|
||||
import Network.Wai.Middleware.RequestLogger
|
||||
( Destination(Logger)
|
||||
, IPAddrSource(..)
|
||||
, OutputFormat(..)
|
||||
, destination
|
||||
, mkRequestLogger
|
||||
, outputFormat
|
||||
)
|
||||
import Yesod.Core
|
||||
import Yesod.Core.Types hiding ( Logger )
|
||||
|
||||
import Auth
|
||||
import Foundation
|
||||
import Handler.Apps
|
||||
import Handler.Authenticate
|
||||
import Handler.Backups
|
||||
import Handler.Hosts
|
||||
import Handler.Icons
|
||||
import Handler.Login
|
||||
import Handler.Notifications
|
||||
import Handler.PasswordUpdate
|
||||
import Handler.PowerOff
|
||||
import Handler.Register
|
||||
import Handler.SelfUpdate
|
||||
import Handler.SshKeys
|
||||
import Handler.Status
|
||||
import Handler.Wifi
|
||||
import Handler.V0
|
||||
import Settings
|
||||
|
||||
-- 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 "AgentCtx" resourcesAgentCtx
|
||||
|
||||
instance YesodSubDispatch Auth AgentCtx where
|
||||
yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth)
|
||||
|
||||
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
|
||||
-- applying some additional middlewares.
|
||||
makeApplication :: AgentCtx -> IO Application
|
||||
makeApplication foundation = do
|
||||
logWare <- makeLogWare foundation
|
||||
-- Create the WAI application and apply middlewares
|
||||
appPlain <- toWaiAppPlain foundation
|
||||
let origin = case appCorsOverrideStar $ appSettings foundation of
|
||||
Nothing -> Nothing
|
||||
Just override -> Just ([encodeUtf8 override], True)
|
||||
pure . logWare . cors (const . Just $ policy origin) . defaultMiddlewaresNoLogging $ appPlain
|
||||
where
|
||||
policy o = simpleCorsResourcePolicy
|
||||
{ corsOrigins = 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
|
||||
}
|
||||
|
||||
startWeb :: AgentCtx -> IO ()
|
||||
startWeb foundation = do
|
||||
app <- makeApplication foundation
|
||||
|
||||
putStrLn @Text $ "Launching Web Server on port " <> show (appPort $ appSettings foundation)
|
||||
action <- async $ runSettings (warpSettings foundation) app
|
||||
|
||||
setWebProcessThreadId (asyncThreadId action) foundation
|
||||
wait action
|
||||
|
||||
shutdownAll :: [ThreadId] -> IO ()
|
||||
shutdownAll threadIds = do
|
||||
for_ threadIds killThread
|
||||
exitSuccess
|
||||
|
||||
shutdownWeb :: AgentCtx -> IO ()
|
||||
shutdownWeb AgentCtx {..} = do
|
||||
mThreadId <- readIORef appWebServerThreadId
|
||||
for_ mThreadId $ \tid -> do
|
||||
killThread tid
|
||||
writeIORef appWebServerThreadId Nothing
|
||||
|
||||
makeLogWare :: AgentCtx -> IO Middleware
|
||||
makeLogWare foundation = mkRequestLogger def
|
||||
{ outputFormat = if appDetailedRequestLogging $ appSettings foundation
|
||||
then Detailed True
|
||||
else Apache (if appIpFromHeader $ appSettings foundation then FromFallback else FromSocket)
|
||||
, destination = Logger $ loggerSet $ appLogger foundation
|
||||
}
|
||||
|
||||
-- | Warp settings for the given foundation value.
|
||||
warpSettings :: AgentCtx -> Settings
|
||||
warpSettings foundation =
|
||||
setPort (fromIntegral . appPort $ appSettings foundation)
|
||||
$ setHost (appHost $ appSettings foundation)
|
||||
$ setOnException
|
||||
(\_req e -> when (defaultShouldDisplayException e) $ messageLoggerSource
|
||||
foundation
|
||||
(appLogger foundation)
|
||||
$(qLocation >>= liftLoc)
|
||||
"yesod"
|
||||
LevelError
|
||||
(toLogStr $ "Exception from Warp: " ++ show e)
|
||||
)
|
||||
defaultSettings
|
||||
Reference in New Issue
Block a user