wai-middleware-auth-0.2.1.0: src/Network/Wai/Middleware/Auth/Provider.hs
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Network.Wai.Middleware.Auth.Provider
( AuthProvider(..)
-- * Provider
, Provider(..)
, ProviderUrl(..)
, ProviderInfo(..)
, Providers
-- * Provider Parsing
, ProviderParser
, mkProviderParser
, parseProviders
-- * User
, AuthUser(..)
, AuthLoginState
, UserIdentity
, authUserIdentity
-- * Template
, mkRouteRender
, providersTemplate
) where
import Blaze.ByteString.Builder (toByteString)
import Control.Arrow (second)
import Data.Aeson (FromJSON (..), Object,
Result (..), Value)
import Data.Aeson.Types (parseEither)
import Data.Aeson.TH (defaultOptions, deriveJSON,
fieldLabelModifier)
import Data.Aeson.Types (Parser)
import Data.Binary (Binary)
import qualified Data.ByteString as S
import qualified Data.ByteString.Builder as B
import qualified Data.HashMap.Strict as HM
import Data.Int
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.Proxy (Proxy)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import GHC.Generics (Generic)
import Network.HTTP.Types (Status, renderQueryText)
import Network.Wai (Request, Response)
import Network.Wai.Auth.Tools (toLowerUnderscore)
import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
import Text.Hamlet (Render, hamlet)
-- | Core Authentication class, that allows for extensibility of the Auth
-- middleware created by `Network.Wai.Middleware.Auth.mkAuthMiddleware`. Most
-- important function is `handleLogin`, which implements the actual behavior of a
-- provider. It's function arguments in order:
--
-- * @`ap`@ - Current provider.
-- * @`Request`@ - Request made to the login page
-- * @[`T.Text`]@ - Url suffix, i.e. last part of the Url split by @\'/\'@ character,
-- for instance @["login", "complete"]@ suffix in the example below.
-- * @`Render` `ProviderUrl`@ -
-- Url renderer. It takes desired suffix as first argument and produces an
-- absolute Url renderer. It can further be used to generate provider urls,
-- for instance in Hamlet templates as
-- will result in
-- @"https:\/\/approot.com\/_auth_middleware\/providerName\/login\/complete?user=Hamlet"@
-- or generate Urls for callbacks.
--
-- @
-- \@?{(ProviderUrl ["login", "complete"], [("user", "Hamlet")])}
-- @
--
-- * @(`AuthLoginState` -> `IO` `Response`)@ - Action to call on a successfull login.
-- * @(`Status` -> `S.ByteString` -> `IO` `Response`)@ - Should be called in case of
-- a failure with login process by supplying a
-- status and a short error message.
class AuthProvider ap where
-- | Return a name for the provider. It will be used as a unique identifier
-- for this provider. Argument should not be evaluated, as there are many
-- places were `undefined` value is passed to this function.
--
-- @since 0.1.0
getProviderName :: ap -> T.Text
-- | Get info about the provider. It will be used in rendering the web page
-- with a list of providers.
--
-- @since 0.1.0
getProviderInfo :: ap -> ProviderInfo
-- | Handle a login request in a custom manner. Can be used to render a login
-- page with a form or redirect to some other authentication service like
-- OpenID or OAuth2.
--
-- @since 0.1.0
handleLogin
:: ap
-> Request
-> [T.Text]
-> Render ProviderUrl
-> (AuthLoginState -> IO Response)
-> (Status -> S.ByteString -> IO Response)
-> IO Response
-- | Generic authentication provider wrapper.
data Provider where
Provider :: AuthProvider p => p -> Provider
instance AuthProvider Provider where
getProviderName (Provider p) = getProviderName p
getProviderInfo (Provider p) = getProviderInfo p
handleLogin (Provider p) = handleLogin p
-- | Collection of supported providers.
type Providers = HM.HashMap T.Text Provider
-- | Aeson parser for a provider with unique provider name (same as returned by
-- `getProviderName`)
type ProviderParser = (T.Text, Value -> Parser Provider)
-- | Data type for rendering Provider specific urls.
newtype ProviderUrl = ProviderUrl [T.Text]
-- | Provider information used for rendering a page with list of supported providers.
data ProviderInfo = ProviderInfo
{ providerTitle :: T.Text
, providerLogoUrl :: T.Text
, providerDescr :: T.Text
} deriving (Show)
-- | An arbitrary state that comes with logged in user, eg. a username, token or an email address.
type AuthLoginState = S.ByteString
type UserIdentity = S.ByteString
{-# DEPRECATED UserIdentity "In favor of `AuthLoginState`" #-}
authUserIdentity :: AuthUser -> UserIdentity
authUserIdentity = authLoginState
{-# DEPRECATED authUserIdentity "In favor of `authLoginState`" #-}
-- | Representation of a user for a particular `Provider`.
data AuthUser = AuthUser
{ authLoginState :: !UserIdentity
, authProviderName :: !S.ByteString
, authLoginTime :: !Int64
} deriving (Generic, Show)
instance Binary AuthUser
-- | First argument is not evaluated and is only needed for restricting the type.
mkProviderParser :: forall ap . (FromJSON ap, AuthProvider ap) => Proxy ap -> ProviderParser
mkProviderParser _ =
( getProviderName nameProxyError
, fmap Provider <$> (parseJSON :: Value -> Parser ap))
where
nameProxyError :: ap
nameProxyError = error "AuthProvider.getProviderName should not evaluate it's argument."
-- | Parse configuration for providers from an `Object`.
parseProviders :: Object -> [ProviderParser] -> Result Providers
parseProviders unparsedProvidersHM providerParsers =
if HM.null unrecognized
then sequence $ HM.intersectionWith parseProvider unparsedProvidersHM parsersHM
else Error $
"Provider name(s) are not recognized: " ++
T.unpack (T.intercalate ", " $ HM.keys unrecognized)
where
parsersHM = HM.fromList providerParsers
unrecognized = HM.difference unparsedProvidersHM parsersHM
parseProvider v p = either Error Success $ parseEither p v
-- | Create a url renderer for a provider.
mkRouteRender :: Maybe T.Text -> T.Text -> [T.Text] -> Render Provider
mkRouteRender appRoot authPrefix authSuffix (Provider p) params =
(T.intercalate "/" $ [root, authPrefix, getProviderName p] ++ authSuffix) <>
decodeUtf8With
lenientDecode
(toByteString $ renderQueryText True (map (second Just) params))
where
root = fromMaybe "" appRoot
$(deriveJSON defaultOptions { fieldLabelModifier = toLowerUnderscore . drop 8} ''ProviderInfo)
-- | Template for the providers page
providersTemplate :: Maybe T.Text -- ^ Error message to display, if any.
-> Render Provider -- ^ Renderer function for provider urls.
-> Providers -- ^ List of available providers.
-> B.Builder
providersTemplate merrMsg render providers =
renderHtmlBuilder $ [hamlet|
$doctype 5
<html>
<head>
<title>WAI Auth Middleware - Authentication Providers.
<link rel="stylesheet" href="https://maxcdn.bootstrapcdn.com/bootstrap/3.3.7/css/bootstrap.min.css" integrity="sha384-BVYiiSIFeK1dGmJRAkycuHAHRg32OmUcww7on3RYdg4Va+PmSTsz/K68vbdEjh4u" crossorigin="anonymous">
<link rel="stylesheet" href="https://maxcdn.bootstrapcdn.com/bootstrap/3.3.7/css/bootstrap-theme.min.css" integrity="sha384-rHyoN1iRsVXV4nD0JutlnGaslCJuC7uwjduW9SVrLvRYooPp2bWYgmgJQIXwl/Sp" crossorigin="anonymous">
<script src="https://ajax.googleapis.com/ajax/libs/jquery/3.1.1/jquery.min.js">
<script src="https://maxcdn.bootstrapcdn.com/bootstrap/3.3.7/js/bootstrap.min.js" integrity="sha384-Tc5IQib027qvyjSMfHjOMaLkfuWVxZxUPnCJA7l2mCWNIpG9mGCD8wGNIcPD7Txa" crossorigin="anonymous">
<style>
.provider-logo {
max-height: 64px;
max-width: 64px;
padding: 5px;
margin: auto;
position: absolute;
top: 0;
bottom: 0;
left: 0;
right: 0;
}
.media-container {
width: 600px;
position: absolute;
top: 100px;
bottom: 0;
left: 0;
right: 0;
margin: auto;
}
.provider.media {
border: 1px solid #e1e1e8;
padding: 5px;
height: 82px;
text-overflow: ellipsis;
margin-top: 5px;
}
.provider.media:hover {
background-color: #f5f5f5;
border: 1px solid #337ab7;
}
.provider .media-left {
height: 70px;
width: 0px;
padding-right: 70px;
position: relative;
}
a:hover {
text-decoration: none;
}
<body>
<div .media-container>
<h3>Select one of available authentication methods:
$maybe errMsg <- merrMsg
<div .alert .alert-danger role="alert">
#{errMsg}
$forall provider <- providers
$with info <- getProviderInfo provider
<div .media.provider>
<a href=@{provider}>
<div .media-left .container>
<img .provider-logo src=#{providerLogoUrl info}>
<div .media-body>
<h3 .media-heading>
#{providerTitle info}
#{providerDescr info}
|] render