{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TemplateHaskell   #-}
module Network.Wai.Auth.Config
  ( AuthConfig(..)
  , SecretKey(..)
  , Service(..)
  , FileServer(..)
  , ReverseProxy(..)
  , encodeKey
  , decodeKey
  ) where

import           Data.Aeson
import           Data.Aeson.TH          (deriveJSON)
import qualified Data.Text              as T
import           Data.Text.Encoding     (encodeUtf8)
import           Network.Wai.Auth.Tools (decodeKey, encodeKey,
                                         toLowerUnderscore)
import           Web.ClientSession      (Key)

-- | Configuration for a secret key that will be used to encrypt authenticated
-- user as client side cookie.
data SecretKey
  = SecretKeyFile FilePath -- ^ Path to a secret key file in binary form, if it
                           -- is malformed or doesn't exist it will be
                           -- (re)created. If empty "client_session_key.aes"
                           -- name will be used
  | SecretKey Key -- ^ Serialized and base64 encoded form of a secret key. Use
                  -- `encodeKey` to get a proper encoded form.


-- | Configuration for reverse proxy application.
data FileServer = FileServer
    { FileServer -> FilePath
fsRootFolder       :: FilePath -- ^ Path to a folder containing files
                                     -- that will be served by this app.
    , FileServer -> Bool
fsRedirectToIndex  :: Bool -- ^ Redirect to the actual index file, not
                                 -- leaving the URL containing the directory
                                 -- name
    , FileServer -> Bool
fsAddTrailingSlash :: Bool -- ^ Add a trailing slash to directory names
    }

-- | Configuration for reverse proxy application.
data ReverseProxy = ReverseProxy
    { ReverseProxy -> Text
rpHost :: T.Text -- ^ Hostname of the webserver
    , ReverseProxy -> Int
rpPort :: Int -- ^ Port of the webserver
    }

-- | Available services.
data Service = ServiceFiles FileServer
             | ServiceProxy ReverseProxy

-- | Configuration for @wai-auth@ executable and any other, that is created using
-- `Network.Wai.Auth.Executable.mkMain`
data AuthConfig = AuthConfig
  { AuthConfig -> Maybe Text
configAppRoot    :: Maybe T.Text -- ^ Root Url of the website, eg:
                                     -- http://example.com or
                                     -- https://example.com It will be used to
                                     -- perform redirects back from external
                                     -- authentication providers.
  , AuthConfig -> Int
configAppPort    :: Int  -- ^ Port number. Default is 3000
  , AuthConfig -> Bool
configRequireTls :: Bool -- ^ Require requests come in over a secure
                             -- connection (determined via headers). Will
                             -- redirect to HTTPS if non-secure
                             -- dedected. Default is @False@
  , AuthConfig -> Bool
configSkipAuth   :: Bool -- ^ Turn off authentication middleware, useful for
                             -- testing. Default is @False@
  , AuthConfig -> Int
configCookieAge  :: Int -- ^ Duration of the session in seconds. Default is
                            -- one hour (3600 seconds).
  , AuthConfig -> SecretKey
configSecretKey  :: SecretKey -- ^ Secret key. Default is "client_session_key.aes"
  , AuthConfig -> Service
configService    :: Service
  , AuthConfig -> Object
configProviders  :: Object
  }

$(deriveJSON defaultOptions { fieldLabelModifier = toLowerUnderscore . drop 2} ''FileServer)

$(deriveJSON defaultOptions { fieldLabelModifier = toLowerUnderscore . drop 2} ''ReverseProxy)

instance FromJSON AuthConfig where
  parseJSON :: Value -> Parser AuthConfig
parseJSON =
    FilePath
-> (Object -> Parser AuthConfig) -> Value -> Parser AuthConfig
forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"Auth Config Object" ((Object -> Parser AuthConfig) -> Value -> Parser AuthConfig)
-> (Object -> Parser AuthConfig) -> Value -> Parser AuthConfig
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
      Maybe Text
configAppRoot <- Object
obj Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"app_root"
      Int
configAppPort <- Object
obj Object -> Text -> Parser (Maybe Int)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"app_port" Parser (Maybe Int) -> Int -> Parser Int
forall a. Parser (Maybe a) -> a -> Parser a
.!= Int
3000
      Bool
configRequireTls <- (Object
obj Object -> Text -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"require_tls" Parser (Maybe Bool) -> Bool -> Parser Bool
forall a. Parser (Maybe a) -> a -> Parser a
.!= Bool
False)
      Bool
configSkipAuth <- Object
obj Object -> Text -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"skip_auth" Parser (Maybe Bool) -> Bool -> Parser Bool
forall a. Parser (Maybe a) -> a -> Parser a
.!= Bool
False
      Int
configCookieAge <- Object
obj Object -> Text -> Parser (Maybe Int)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"cookie_age" Parser (Maybe Int) -> Int -> Parser Int
forall a. Parser (Maybe a) -> a -> Parser a
.!= Int
3600
      Maybe Text
mSecretKeyB64T <- Object
obj Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"secret_key"
      SecretKey
configSecretKey <-
        case Maybe Text
mSecretKeyB64T of
          Just Text
secretKeyB64T ->
            (FilePath -> Parser SecretKey)
-> (Key -> Parser SecretKey)
-> Either FilePath Key
-> Parser SecretKey
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> Parser SecretKey
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (SecretKey -> Parser SecretKey
forall (m :: * -> *) a. Monad m => a -> m a
return (SecretKey -> Parser SecretKey)
-> (Key -> SecretKey) -> Key -> Parser SecretKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SecretKey
SecretKey) (Either FilePath Key -> Parser SecretKey)
-> Either FilePath Key -> Parser SecretKey
forall a b. (a -> b) -> a -> b
$ ByteString -> Either FilePath Key
decodeKey (Text -> ByteString
encodeUtf8 Text
secretKeyB64T)
          Maybe Text
Nothing -> FilePath -> SecretKey
SecretKeyFile (FilePath -> SecretKey) -> Parser FilePath -> Parser SecretKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
obj Object -> Text -> Parser (Maybe FilePath)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"secret_key_file" Parser (Maybe FilePath) -> FilePath -> Parser FilePath
forall a. Parser (Maybe a) -> a -> Parser a
.!= FilePath
"")
      Maybe Value
mFileServer <- Object
obj Object -> Text -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"file_server"
      Maybe Value
mReverseProxy <- Object
obj Object -> Text -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"reverse_proxy"
      let sErrMsg :: FilePath
sErrMsg =
            FilePath
"Either 'file_server' or 'reverse_proxy' is required, but not both."
      Service
configService <-
        case (Maybe Value
mFileServer, Maybe Value
mReverseProxy) of
          (Just Value
fileServer, Maybe Value
Nothing) -> FileServer -> Service
ServiceFiles (FileServer -> Service) -> Parser FileServer -> Parser Service
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser FileServer
forall a. FromJSON a => Value -> Parser a
parseJSON Value
fileServer
          (Maybe Value
Nothing, Just Value
reverseProxy) ->
            ReverseProxy -> Service
ServiceProxy (ReverseProxy -> Service) -> Parser ReverseProxy -> Parser Service
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser ReverseProxy
forall a. FromJSON a => Value -> Parser a
parseJSON Value
reverseProxy
          (Just Value
_, Just Value
_) -> FilePath -> Parser Service
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Parser Service) -> FilePath -> Parser Service
forall a b. (a -> b) -> a -> b
$ FilePath
"Too many services. " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
sErrMsg
          (Maybe Value
Nothing, Maybe Value
Nothing) -> FilePath -> Parser Service
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Parser Service) -> FilePath -> Parser Service
forall a b. (a -> b) -> a -> b
$ FilePath
"No service is supplied. " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
sErrMsg
      Object
configProviders <- Object
obj Object -> Text -> Parser Object
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"providers"
      AuthConfig -> Parser AuthConfig
forall (m :: * -> *) a. Monad m => a -> m a
return AuthConfig :: Maybe Text
-> Int
-> Bool
-> Bool
-> Int
-> SecretKey
-> Service
-> Object
-> AuthConfig
AuthConfig {Bool
Int
Maybe Text
Object
Service
SecretKey
configProviders :: Object
configService :: Service
configSecretKey :: SecretKey
configCookieAge :: Int
configSkipAuth :: Bool
configRequireTls :: Bool
configAppPort :: Int
configAppRoot :: Maybe Text
configProviders :: Object
configService :: Service
configSecretKey :: SecretKey
configCookieAge :: Int
configSkipAuth :: Bool
configRequireTls :: Bool
configAppPort :: Int
configAppRoot :: Maybe Text
..}