{-# 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)
data SecretKey
= SecretKeyFile FilePath
| SecretKey Key
data FileServer = FileServer
{ FileServer -> FilePath
fsRootFolder :: FilePath
, FileServer -> Bool
fsRedirectToIndex :: Bool
, FileServer -> Bool
fsAddTrailingSlash :: Bool
}
data ReverseProxy = ReverseProxy
{ ReverseProxy -> Text
rpHost :: T.Text
, ReverseProxy -> Int
rpPort :: Int
}
data Service = ServiceFiles FileServer
| ServiceProxy ReverseProxy
data AuthConfig = AuthConfig
{ AuthConfig -> Maybe Text
configAppRoot :: Maybe T.Text
, AuthConfig -> Int
configAppPort :: Int
, AuthConfig -> Bool
configRequireTls :: Bool
, AuthConfig -> Bool
configSkipAuth :: Bool
, AuthConfig -> Int
configCookieAge :: Int
, AuthConfig -> SecretKey
configSecretKey :: SecretKey
, 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
..}