{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.Wai.Auth.Executable
( mkMain
, readAuthConfig
, serviceToApp
, module Network.Wai.Auth.Config
, Port
) where
import Data.Aeson (Result (..))
import Data.String (fromString)
import Data.Text.Encoding (encodeUtf8)
import Data.Yaml.Config (loadYamlSettings, useEnv)
import Network.HTTP.Client.TLS (getGlobalManager)
import Network.HTTP.ReverseProxy (ProxyDest (..),
WaiProxyResponse (WPRProxyDest),
defaultOnExc, waiProxyTo)
import Network.Wai (Application)
import Network.Wai.Application.Static (defaultFileServerSettings,
ssAddTrailingSlash,
ssRedirectToIndex,
staticApp)
import Network.Wai.Auth.Config
import Network.Wai.Middleware.Auth
import Network.Wai.Middleware.Auth.Provider
import Network.Wai.Middleware.ForceSSL (forceSSL)
import Web.ClientSession (getKey)
type Port = Int
serviceToApp :: Service -> IO Application
serviceToApp :: Service -> IO Application
serviceToApp (ServiceFiles FileServer {Bool
FilePath
fsAddTrailingSlash :: FileServer -> Bool
fsRedirectToIndex :: FileServer -> Bool
fsRootFolder :: FileServer -> FilePath
fsAddTrailingSlash :: Bool
fsRedirectToIndex :: Bool
fsRootFolder :: FilePath
..}) = do
Application -> IO Application
forall (m :: * -> *) a. Monad m => a -> m a
return (Application -> IO Application) -> Application -> IO Application
forall a b. (a -> b) -> a -> b
$
StaticSettings -> Application
staticApp
(FilePath -> StaticSettings
defaultFileServerSettings (FilePath -> StaticSettings) -> FilePath -> StaticSettings
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
forall a. IsString a => FilePath -> a
fromString FilePath
fsRootFolder)
{ ssRedirectToIndex :: Bool
ssRedirectToIndex = Bool
fsRedirectToIndex
, ssAddTrailingSlash :: Bool
ssAddTrailingSlash = Bool
fsAddTrailingSlash
}
serviceToApp (ServiceProxy (ReverseProxy Text
host Int
port)) = do
Manager
manager <- IO Manager
getGlobalManager
Application -> IO Application
forall (m :: * -> *) a. Monad m => a -> m a
return (Application -> IO Application) -> Application -> IO Application
forall a b. (a -> b) -> a -> b
$
(Request -> IO WaiProxyResponse)
-> (SomeException -> Application) -> Manager -> Application
waiProxyTo
(IO WaiProxyResponse -> Request -> IO WaiProxyResponse
forall a b. a -> b -> a
const (IO WaiProxyResponse -> Request -> IO WaiProxyResponse)
-> IO WaiProxyResponse -> Request -> IO WaiProxyResponse
forall a b. (a -> b) -> a -> b
$ WaiProxyResponse -> IO WaiProxyResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (WaiProxyResponse -> IO WaiProxyResponse)
-> WaiProxyResponse -> IO WaiProxyResponse
forall a b. (a -> b) -> a -> b
$ ProxyDest -> WaiProxyResponse
WPRProxyDest (ProxyDest -> WaiProxyResponse) -> ProxyDest -> WaiProxyResponse
forall a b. (a -> b) -> a -> b
$ ByteString -> Int -> ProxyDest
ProxyDest (Text -> ByteString
encodeUtf8 Text
host) Int
port)
SomeException -> Application
defaultOnExc
Manager
manager
readAuthConfig :: FilePath -> IO AuthConfig
readAuthConfig :: FilePath -> IO AuthConfig
readAuthConfig FilePath
confFile = [FilePath] -> [Value] -> EnvUsage -> IO AuthConfig
forall settings.
FromJSON settings =>
[FilePath] -> [Value] -> EnvUsage -> IO settings
loadYamlSettings [FilePath
confFile] [] EnvUsage
useEnv
mkMain
:: AuthConfig
-> [ProviderParser]
-> (Port -> Application -> IO ())
-> IO ()
mkMain :: AuthConfig
-> [ProviderParser] -> (Int -> Application -> IO ()) -> IO ()
mkMain AuthConfig {Bool
Int
Maybe Text
Object
Service
SecretKey
configProviders :: AuthConfig -> Object
configService :: AuthConfig -> Service
configSecretKey :: AuthConfig -> SecretKey
configCookieAge :: AuthConfig -> Int
configSkipAuth :: AuthConfig -> Bool
configRequireTls :: AuthConfig -> Bool
configAppPort :: AuthConfig -> Int
configAppRoot :: AuthConfig -> Maybe Text
configProviders :: Object
configService :: Service
configSecretKey :: SecretKey
configCookieAge :: Int
configSkipAuth :: Bool
configRequireTls :: Bool
configAppPort :: Int
configAppRoot :: Maybe Text
..} [ProviderParser]
providerParsers Int -> Application -> IO ()
run = do
let !providers :: Providers
providers =
case Object -> [ProviderParser] -> Result Providers
parseProviders Object
configProviders [ProviderParser]
providerParsers of
Error FilePath
errMsg -> FilePath -> Providers
forall a. HasCallStack => FilePath -> a
error FilePath
errMsg
Success Providers
providers' -> Providers
providers'
let authSettings :: AuthSettings
authSettings =
(case SecretKey
configSecretKey of
SecretKey Key
key -> IO Key -> AuthSettings -> AuthSettings
setAuthKey (IO Key -> AuthSettings -> AuthSettings)
-> IO Key -> AuthSettings -> AuthSettings
forall a b. (a -> b) -> a -> b
$ Key -> IO Key
forall (m :: * -> *) a. Monad m => a -> m a
return Key
key
SecretKeyFile FilePath
"" -> AuthSettings -> AuthSettings
forall a. a -> a
id
SecretKeyFile FilePath
keyPath -> IO Key -> AuthSettings -> AuthSettings
setAuthKey (FilePath -> IO Key
getKey FilePath
keyPath))
(AuthSettings -> AuthSettings)
-> (AuthSettings -> AuthSettings) -> AuthSettings -> AuthSettings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (case Maybe Text
configAppRoot of
Just Text
appRoot -> Text -> AuthSettings -> AuthSettings
setAuthAppRootStatic Text
appRoot
Maybe Text
Nothing -> AuthSettings -> AuthSettings
forall a. a -> a
id)
(AuthSettings -> AuthSettings)
-> (AuthSettings -> AuthSettings) -> AuthSettings -> AuthSettings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Providers -> AuthSettings -> AuthSettings
setAuthProviders Providers
providers
(AuthSettings -> AuthSettings)
-> (AuthSettings -> AuthSettings) -> AuthSettings -> AuthSettings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> AuthSettings -> AuthSettings
setAuthSessionAge Int
configCookieAge
(AuthSettings -> AuthSettings) -> AuthSettings -> AuthSettings
forall a b. (a -> b) -> a -> b
$ AuthSettings
defaultAuthSettings
Middleware
authMiddleware <- AuthSettings -> IO Middleware
mkAuthMiddleware AuthSettings
authSettings
Application
app <- Service -> IO Application
serviceToApp Service
configService
Int -> Application -> IO ()
run Int
configAppPort (Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$
(if Bool
configRequireTls
then Middleware
forceSSL
else Middleware
forall a. a -> a
id)
(if Bool
configSkipAuth
then Application
app
else Middleware
authMiddleware Application
app)