{-# 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

-- | Create an `Application` from a `Service`
--
-- @since 0.1.0
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


-- | Read configuration from a yaml file with ability to use environment
-- variables. See "Data.Yaml.Config" module for details.
--
-- @since 0.1.0
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


-- | Construct a @main@ function.
--
-- @since 0.1.0
mkMain
  :: AuthConfig -- ^ Use `readAuthConfig` to read config from a file.
  -> [ProviderParser]
  -- ^ Parsers for supported providers. `ProviderParser` can be created with
  -- `Network.Wai.Middleware.Auth.Provider.mkProviderParser`.
  -> (Port -> Application -> IO ())
  -- ^ Application runner, for instance Warp's @run@ function.
  -> 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)