module Network.Wai.Middleware.Auth
(
AuthSettings
, defaultAuthSettings
, setAuthKey
, setAuthAppRootStatic
, setAuthAppRootGeneric
, setAuthSessionAge
, setAuthPrefix
, setAuthCookieName
, setAuthProviders
, setAuthProvidersTemplate
, mkAuthMiddleware
, smartAppRoot
, waiMiddlewareAuthVersion
, getAuthUser
) where
import Blaze.ByteString.Builder (fromByteString)
import Data.Binary (Binary)
import qualified Data.ByteString as S
import Data.ByteString.Builder (Builder)
import qualified Data.HashMap.Strict as HM
import Data.Monoid ((<>))
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With,
encodeUtf8)
import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.Vault.Lazy as Vault
import Data.Version (Version)
import Foreign.C.Types (CTime (..))
import GHC.Generics (Generic)
import Network.HTTP.Types (status200, status303,
status404, status501)
import Network.Wai (Middleware, Request,
pathInfo, rawPathInfo,
rawQueryString,
responseBuilder,
responseLBS, vault)
import Network.Wai.Auth.AppRoot
import Network.Wai.Auth.ClientSession
import Network.Wai.Middleware.Auth.Provider
import qualified Paths_wai_middleware_auth as Paths
import System.IO.Unsafe (unsafePerformIO)
import System.PosixCompat.Time (epochTime)
import Text.Hamlet (Render)
data AuthSettings = AuthSettings
{ asGetKey :: IO Key
, asGetAppRoot :: Request -> IO T.Text
, asSessionAge :: Int
, asAuthPrefix :: T.Text
, asStateKey :: S.ByteString
, asProviders :: Providers
, asProvidersTemplate :: Maybe T.Text -> Render Provider -> Providers -> Builder
}
defaultAuthSettings :: AuthSettings
defaultAuthSettings =
AuthSettings
{ asGetKey = getDefaultKey
, asGetAppRoot = return <$> smartAppRoot
, asSessionAge = 3600
, asAuthPrefix = "_auth_middleware"
, asStateKey = "auth_state"
, asProviders = HM.empty
, asProvidersTemplate = providersTemplate
}
setAuthKey :: IO Key -> AuthSettings -> AuthSettings
setAuthKey x as = as { asGetKey = x }
setAuthCookieName :: S.ByteString -> AuthSettings -> AuthSettings
setAuthCookieName x as = as { asStateKey = x }
setAuthPrefix :: T.Text -> AuthSettings -> AuthSettings
setAuthPrefix x as = as { asAuthPrefix = x }
setAuthAppRootStatic :: T.Text -> AuthSettings -> AuthSettings
setAuthAppRootStatic = setAuthAppRootGeneric . const . return
setAuthAppRootGeneric :: (Request -> IO T.Text) -> AuthSettings -> AuthSettings
setAuthAppRootGeneric x as = as { asGetAppRoot = x }
setAuthSessionAge :: Int -> AuthSettings -> AuthSettings
setAuthSessionAge x as = as { asSessionAge = x }
setAuthProviders :: Providers -> AuthSettings -> AuthSettings
setAuthProviders !ps as = as { asProviders = ps }
setAuthProvidersTemplate :: (Maybe T.Text -> Render Provider -> Providers -> Builder)
-> AuthSettings
-> AuthSettings
setAuthProvidersTemplate t as = as { asProvidersTemplate = t }
data AuthState = AuthNeedRedirect !S.ByteString
| AuthLoggedIn !AuthUser
deriving (Generic, Show)
instance Binary AuthState
mkAuthMiddleware :: AuthSettings -> IO Middleware
mkAuthMiddleware AuthSettings {..} = do
secretKey <- asGetKey
let saveAuthState = saveCookieValue secretKey asStateKey asSessionAge
authRouteRender = mkRouteRender Nothing asAuthPrefix []
let enforceLogin protectedPath req respond =
case pathInfo req of
(prefix:rest)
| prefix == asAuthPrefix ->
case rest of
[] ->
case HM.elems asProviders of
[] ->
respond $
responseLBS
status501
[]
"No Authentication providers available."
[soleProvider] ->
let loginUrl =
encodeUtf8 $ authRouteRender soleProvider []
in respond $
responseLBS
status303
[("Location", loginUrl)]
"Redirecting to Login page"
_ ->
respond $
responseBuilder status200 [] $
asProvidersTemplate Nothing authRouteRender asProviders
(providerName:pathSuffix)
| Just provider <- HM.lookup providerName asProviders -> do
appRoot <- asGetAppRoot req
let onFailure status errMsg =
return $
responseBuilder status [] $
asProvidersTemplate
(Just $ decodeUtf8With lenientDecode errMsg)
authRouteRender
asProviders
let onSuccess "" =
onFailure
status501
"Empty user identity is not allowed"
onSuccess userIdentity = do
CTime now <- epochTime
cookie <-
saveAuthState $
AuthLoggedIn $
AuthUser
{ authUserIdentity = userIdentity
, authProviderName =
encodeUtf8 $ getProviderName provider
, authLoginTime = fromIntegral now
}
return $
responseBuilder
status303
[("Location", protectedPath), cookie]
(fromByteString "Redirecting to " <>
fromByteString protectedPath)
let providerUrlRenderer (ProviderUrl suffix) =
mkRouteRender
(Just appRoot)
asAuthPrefix
suffix
provider
respond =<<
handleLogin
provider
req
pathSuffix
providerUrlRenderer
onSuccess
onFailure
_ -> respond $ responseLBS status404 [] "Unknown URL"
["favicon.ico"] -> respond $ responseLBS status404 [] "No favicon.ico"
_ -> do
cookie <-
saveAuthState $
AuthNeedRedirect (rawPathInfo req <> rawQueryString req)
respond $
responseBuilder
status303
[("Location", "/" <> encodeUtf8 asAuthPrefix), cookie]
"Redirecting to Login Page"
return $ \app req respond -> do
authState <- loadCookieValue secretKey asStateKey req
case authState of
Just (AuthLoggedIn user) ->
let req' = req {vault = Vault.insert userKey user $ vault req}
in app req' respond
Just (AuthNeedRedirect url) -> enforceLogin url req respond
Nothing -> enforceLogin "/" req respond
userKey :: Vault.Key AuthUser
userKey = unsafePerformIO Vault.newKey
getAuthUser :: Request -> Maybe AuthUser
getAuthUser = Vault.lookup userKey . vault
waiMiddlewareAuthVersion :: Version
waiMiddlewareAuthVersion = Paths.version